;;;
;;; raven-mmu.lisp
;;;
;;; Memory address translation.
;;;

(in-package :raven)

(declaim (inline write-map-level-2-address))
(defun write-map-level-2-address ()
  (let* ((map-1 (aref *level-1-map* (ldb (byte 12 13) (aref *memory-data*))))
	 (map-2-address (dpb map-1 (byte 7 5)
			     (ldb (byte 5 8) (aref *memory-data*)))))
    (setf (aref *level-2-address* map-2-address) (aref *virtual-memory-address*)))
  (values))

(declaim (inline write-map-level-2-control))
(defun write-map-level-2-control ()
  (let* ((map-1 (aref *level-1-map* (ldb (byte 12 13) (aref *memory-data*))))
	 (map-2-address (dpb map-1 (byte 7 5)
			     (ldb (byte 5 8) (aref *memory-data*)))))
    (setf (aref *level-2-control* map-2-address) (aref *virtual-memory-address*)))
  (values))

(declaim (inline start-unmapped-read))
(defun start-unmapped-read (address)
  (if (zerop (logand 1 address))
      (nubus-read (ldb (byte 8 24) address) (ldb (byte 24 0) address) :word)
      (nubus-read (ldb (byte 8 24) address) (ldb (byte 24 0) (logand -2 address)) :half)))

(declaim (inline start-unmapped-write))
(defun start-unmapped-write (address)
  (if (zerop (logand 1 address))
      (nubus-write (ldb (byte 8 24) address) (ldb (byte 24 0) address) :word)
      (nubus-write (ldb (byte 8 24) address) (ldb (byte 24 0) (logand -2 address)) :half)))

(declaim (inline start-unmapped-byte-read))
(defun start-unmapped-byte-read (address)
  (nubus-read (ldb (byte 8 24) address) (ldb (byte 24 0) address) :byte))

(declaim (inline start-unmapped-byte-write))
(defun start-unmapped-byte-write (address)
  (nubus-write (ldb (byte 8 24) address) (ldb (byte 24 0) address) :byte))

(declaim (type (simple-array (unsigned-byte 32) ()) *cached-level-2-control*))
(defvar *cached-level-2-control* (make-array () :element-type '(unsigned-byte 32) :initial-element 0))

(defun start-read ()
  (let* ((map-1-index (ldb (byte 12 13) (aref *virtual-memory-address*)))
	 (lvl1 (aref *level-1-map* map-1-index))
	 (map-2-index (dpb lvl1 (byte 7 5) (ldb (byte 5 8) (aref *virtual-memory-address*))))
	 (map-2-control (aref *level-2-control* map-2-index))
	 (map-2-address (aref *level-2-address* map-2-index)))
    (setf (aref *cached-level-2-control*) map-2-control)
    (setf *page-fault* nil)
;    (unless (zerop (logand (aref *virtual-memory-address*) #xfe000000))
;      (format t "start-read: address ~8,'0X, mcr ~8,'0X, l1 ~8,'0X, l2c ~8,'0X, l2a ~8,'0X.~%" (aref *virtual-memory-address*) *machine-control-register* lvl1 map-2-control map-2-address)
;      )
;    (format t "Level1: ~X~%" lvl1)
    (when (zerop (logand #x800 lvl1))
      (setf *page-fault* t)
;      (format t "Level 1 page fault.~%")
      (return-from start-read))
    
;    (format t "Level2Ctrl: ~X~%" map-2-control)
;    (format t "Level2Addr: ~X~%" map-2-address)
    (when (zerop (logand #x200 map-2-control))
      (setf *page-fault* t)
      (format t "Level 2 page fault.~%")
      (return-from start-read))
    
    (setf (aref *level-1-map* map-1-index)
	  (dpb (- 1 (ldb (byte 1 9) *machine-control-register*))
	       (byte 1 14) lvl1))

#+nil    (setf (aref *level-2-control* map-2-index)
	  (dpb (- 1 (ldb (byte 1 10) *machine-control-register*))
	       (byte 1 13) map-2-control))

    (start-unmapped-read (ash (dpb map-2-address (byte 22 8) (logand #xff (aref *virtual-memory-address*))) 2))))

(defun start-write ()
  (let* ((map-1-index (ldb (byte 12 13) (aref *virtual-memory-address*)))
	 (lvl1 (aref *level-1-map* map-1-index))
	 (map-2-index (dpb lvl1 (byte 7 5) (ldb (byte 5 8) (aref *virtual-memory-address*))))
	 (map-2-control (aref *level-2-control* map-2-index))
	 (map-2-address (aref *level-2-address* map-2-index)))
    (setf (aref *cached-level-2-control*) map-2-control)
    (setf *page-fault* nil)
;    (format t "start-write: address ~8,'0X, mcr ~8,'0X, l1 ~8,'0X, l2c ~8,'0X, l2a ~8,'0X.~%" (aref *virtual-memory-address*) *machine-control-register* lvl1 map-2-control map-2-address)
;    (format t "Level1: ~X~%" lvl1)
    (when (zerop (logand #x800 lvl1))
      (setf *page-fault* t)
      (format t "Level 1 page fault.~%")
      (return-from start-write))
    
;    (format t "Level2Ctrl: ~X~%" map-2-control)
;    (format t "Level2Addr: ~X~%" map-2-address)
    (when (zerop (logand #x200 map-2-control))
      (setf *page-fault* t)
      (format t "Level 2 page fault.~%")
      (return-from start-write))
    
    (when (zerop (logand #x100 map-2-control))
      (setf *page-fault* t)
      (format t "Level 2 write page fault.~%")
      (return-from start-write))
    
    (setf (aref *level-1-map* map-1-index)
	  (dpb (- 1 (ldb (byte 1 9) *machine-control-register*))
	       (byte 1 14) lvl1))

    (setf (aref *level-2-control* map-2-index)
	  (dpb (- 1 (ldb (byte 1 10) *machine-control-register*))
	       (byte 1 13) map-2-control))

    (start-unmapped-write (ash (dpb map-2-address (byte 22 8) (logand #xff (aref *virtual-memory-address*))) 2))))


;;; EOF
