;;; -*- Mode:LISP; Package:MAP-FAULT; Base:10; Readtable:CL -*-

(defun swap-in-internal (virtual-cluster)
  (let* ((virtual-quantum (vinc:cluster-quantum virtual-cluster))
	 (quantum-map-entry (quantum-map:read-quantum-map virtual-quantum))
	 (status-bits (quantum-map:quantum-status-bits quantum-map-entry))
	 (paging-device (array:svref li:*paging-devices* (quantum-map:quantum-device quantum-map-entry)))
	 (quantum-dqin (quantum-map:quantum-dqin quantum-map-entry))
	 (region (quantum-map:region-origin virtual-quantum))
	 physical-cluster
	 )
    ;; Error checking first.
    ;; To swap in a cluster, its associated quantum must have a valid entry in the quantum map table, i.e.,
    ;; it had to have been written at some point in the past. The entry in the map must be have both the valid
    ;; and mapped bit on at the same time, otherwise it is an error.
    (and (quantum-map:quantum-valid? status-bits)
	 (li:error "quantum ~D has not been allocated yet." virtual-quantum status-bits))
    (and (not (= status-bits quantum-map:$$quantum-mapped))
	 (li:error "Quantum ~D is not mapped to any paging device" virtual-quantum status-bits))
    (when (not paging-device)
      (li:error "Quantum ~D is not associated with any paging device." virtual-quantum))
    ;; get a physical cluster to write to.
    (setq physical-cluster (pcd:allocate-physical-cluster))
    (li:begin-read paging-device quantum-dqin (hw:ldb virtual-cluster (byte 4 0) 0))
    (li:next-read-cluster paging-device physical-cluster)
    (li:do-the-read paging-device)
    ;; map it to virtual-cluster
    (pcd:associate-cluster
      physical-cluster
      virtual-cluster
      pcd:$$status-normal
      (region-bits:region-read-only region)
      pcd:$$cluster-no-read-mar
      pcd:$$cluster-no-write-mar)
    )
  )

(defun page-out-page-and-change-device-for-quantum (virtual-quantum old-dqin region cluster-to-write physical-cluster
						    &optional (from-paging-device-id li:*boot-band-paging-device-id*)
						    (To-paging-device-id li:*page-band-paging-device-id*))
  ;; should check for valid paging device ids.
  (let ((from-paging-device (array:svref li:*paging-devices* from-paging-device-id))
	(To-paging-device (array:svref li:*paging-devices* To-paging-device-id))
	(cluster (vinc:quantum->cluster virtual-quantum))
	new-dqin map-entry)
    (or from-paging-device
	(li:error "No source paging device is specified for quantum ~S" virtual-quantum))
    (or To-paging-device
	(li:error "No destination paging device is specified for quantum ~S" virtual-quantum))
    (setq new-dqin (li:allocate-quantum to-paging-device))
    ;; write out the cluster to be swapped out any way.
    (li:begin-write To-paging-device new-dqin (hw:ldb cluster (byte 4 0) 0))
    (li:next-write-cluster to-paging-device physical-cluster)
    (li:do-the-write to-paging-device)
    ;; now make sure that all the pages still in boot device are copied to paging band device.
    ;; use cluster physical-cluster-to-write for the transfer.
    (dotimes (virtual-cluster-offset 16.)
      (setq cluster (hw:dpb virtual-cluster-offset (byte 4. 10.) cluster))
      (unless (= cluster cluster-to-write)
	(setq map-entry (map:read-map cluster))
	(if (= (map:map-lisp-valid-bit map-entry) 1)
	    ;; already in core. Dirty it and let go.
	    (map:write-map cluster (hw:dpb 1 hw:%%map-lisp-write-enable-bit map-entry))
	  ;; otherwise page in and out to new device.
	  (progn
	    (associate-cluster
	      physical-cluster
	      cluster
	      pcd:$$status-normal
	      (region-bits:region-read-only region) nil nil)
	    (li:begin-read from-paging-device old-dqin (hw:ldb cluster (byte 4 0) 0))
	    (li:next-read-cluster from-paging-device physical-cluster)
	    (li:do-the-read from-paging-device)
	    (li:begin-write To-paging-device new-dqin (hw:ldb cluster (byte 4 0) 0))
	    (li:next-write-cluster to-paging-device physical-cluster)
	    (li:do-the-write to-paging-device))
	  )
	)
      )
    ;; update quantum map.
    (quantum-map:modify-quantum-map virtual-quantum
				    #'(lambda (To)
					(hw:dpb
					  new-dqin
					  quantum-map:%%quantum-map-dqin
					  (hw:dpb
					    to-paging-device-id
					    quantum-map:%%quantum-map-device
					    (hw:dpb 1 quantum-map:%%quantum-map-mapped-bit To)))))
    )
  )

(defun swap-out-internal (physical-cluster)
  (let* ((pcd-data (pcd:read-pcd physical-cluster))
	 (virtual-cluster (pcd:pcd-virtual-cluster-number pcd-data)))
    (when (not (pcd:clean-cluster? pcd-data))
      (let* ((virtual-quantum (quantum-map:cluster-quantum virtual-cluster))
	     (quantum-map-entry (quantum-map:read-quantum-map virtual-quantum))
	     (status-bits (quantum-map:quantum-status-bits quantum-map-entry))
	     (paging-device-id (quantum-map:quantum-device quantum-map-entry))
	     (paging-device (array:svref li:*paging-devices* paging-device-id))
	     (quantum-dqin (quantum-map:quantum-dqin quantum-map-entry))
	     (region (quantum-map:region-origin virtual-quantum))
	     )
	;; Error checking first.
	(dispatch (byte 2 0) status-bits
		  (quantum-map:$$quantum-allocated
		    (setq quantum-dqin (li:allocate-quantum paging-device))
		    (quantum-map:modify-quantum-map
		      virtual-quantum
		      #'(lambda (q) (vinc:dpb-multiple-unboxed
				      quantum-dqin                 quantum-map:%%quantum-map-dqin
				      quantum-map:$$quantum-mapped quantum-map:%%quantum-map-status
				      q))))
		  (quantum-map:$$quantum-mapped nil)
		  (t
		    (li:error "quantum ~D has not been allocated yet." virtual-quantum status-bits)))
	(if (= paging-device-id li:*boot-band-paging-device-id*)
	    (page-out-page-and-change-device-for-quantum
	      virtual-quantum
	      quantum-dqin
	      virtual-cluster
	      physical-cluster
	      li:*boot-band-paging-device-id*
	      li:*page-band-paging-device-id*)
	  ;; just write out the page. it is on the paging band.
	  (progn
	    (li:begin-write paging-device quantum-dqin (hw:ldb virtual-cluster (byte 4 0) 0))
	    (li:next-write-cluster paging-device physical-cluster)
	    (li:do-the-write paging-device)))))
    (map:free-swapped-out-virtual-cluster virtual-cluster)
    (pcd:free-physical-cluster physical-cluster)
    )
  )

(defun swapin-cluster-and-wire-it (virtual-cluster)
  (do ((success nil)
       (address (vinc:cluster->address virtual-cluster)))
      (success)
    (hw:vma-start-read-no-transport-vma-unboxed-md-unboxed address)
    (hw:read-md)
    (hw:nop)
    (hw:nop)
    (trap:without-traps
      #'(lambda ()
	  (let ((map-data (hw:read-map)))
	  (when (= (map:map-lisp-valid-bit map-data) hw:$$map-valid)
	    (let ((pcd (map:map-on-board-address map-data)))
	      (pcd:modify-pcd pcd
			      #'(lambda (pcd-data)
				  (setf (pcd:pcd-status pcd-data) pcd:$$status-wired))))
	    (setq success t))))))
  )

(defun icache-map-fault-handler (pc+)
;  (when (not (= gr::*page-fault-code* *page-fault-code-idle*))
;    (trap::illop "Recursively entered icache page fault handler."))
  (setq gr::*page-fault-code* *page-fault-code-icache-fault*)
  (let* ((address (k2:pc->addr pc+))
	 (map-bits (map:read-map (vinc:cluster-number address))))
    (vinc:flush-icache)
    ;; Don't need to know if they were off because we are called only from
    ;; the trap handler (so far).
    (trap::trap-on)
    (dispatch (byte 4. 0.) (extract-map-status map-bits)
	      ($$map-status-read-only-aged (icache-aged        address map-bits))
	      ($$map-status-swapped-out    (icache-swapped-out address map-bits))
	      (t                           (icache-error       address map-bits pc+)))))

(defun icache-error (address map-bits pc+)
  (trap::illop "Icache-error called."))

(defun icache-aged (vma map-bits)
  (hw:trap-off)
  (hw:write-vma vma)
  (map:touch-aged map-bits)
  (pcd:rejuvenate-cluster (map-on-board-address map-bits))
  (setq gr::*page-fault-code* *page-fault-code-idle*)
  )

(defun icache-swapped-out (vma map-bits)
  (let ((virtual-cluster (vinc:cluster-number vma)))
    (if (fresh-cluster? virtual-cluster)
	(trap::illop "Icache fault on fresh cluster.")
      (swap-in-internal virtual-cluster)))
  (hw:trap-off)
  (setq gr::*page-fault-code* *page-fault-code-idle*))