;;-*- MODE: LISP; PACKAGE: SI -*-
;Virtual virtual memory for the lisp machine.  Initial (and hopefully only)
; application is making cold-load s directly on disk bands.
(DEFVAR VM-PARTITION NIL)
(DEFVAR VM-UNIT NIL)

(DEFVAR VM-PARTITION-BASE NIL)
(DEFVAR VM-PARTITION-MAX NIL)

(DEFVAR VM-NUMBER-PAGE-BUFFERS 10)

(DEFVAR VM-PAGE-RQBS NIL)		;RQB FOR BUFFER
(DEFVAR VM-PAGE-BUFFERS NIL)		;ARRAY WHICH POINTS TO DATA OF RQB
(DEFVAR VM-PAGE-DISK-ADDRESSES NIL)   ;DISK ADDRESS WHICH THIS BUFFER HOLDS
(DEFVAR VM-PAGE-AGES NIL)	;TIME THIS BUFFER LAST REF'ED

(DEFVAR VM-AGE 0)

(DEFUN VM-SETUP (PARTITION UNIT &OPTIONAL NO-ASK)
  (COND ((NULL NO-ASK)
	 (FORMAT T "~%Do you really want to use Partition ~s, Unit ~s as virtual^2 memory?"
		 PARTITION UNIT)))
  (COND ((OR NO-ASK (Y-OR-N-P))
	 (MULTIPLE-VALUE (VM-PARTITION-BASE VM-PARTITION-MAX)
	   (FIND-DISK-PARTITION PARTITION NIL UNIT))
	 (SETQ VM-PARTITION PARTITION)
	 (SETQ VM-UNIT UNIT)
	 (COND ((NULL VM-PAGE-BUFFERS)
		(VM-SETUP-PAGE-BUFFERS)))
	 (DOTIMES (C VM-NUMBER-PAGE-BUFFERS)
	   (AS-1 NIL VM-PAGE-DISK-ADDRESSES C))
	 (VM-RESET-AGES)
	 )))

(DEFUN VM-SETUP-PAGE-BUFFERS NIL
  (SETQ VM-PAGE-RQBS (MAKE-ARRAY NIL 'ART-Q VM-NUMBER-PAGE-BUFFERS))
  (SETQ VM-PAGE-BUFFERS (MAKE-ARRAY NIL 'ART-Q VM-NUMBER-PAGE-BUFFERS))
  (SETQ VM-PAGE-DISK-ADDRESSES (MAKE-ARRAY NIL 'ART-Q VM-NUMBER-PAGE-BUFFERS))
  (SETQ VM-PAGE-AGES (MAKE-ARRAY NIL 'ART-Q VM-NUMBER-PAGE-BUFFERS))
  (DOTIMES (C VM-NUMBER-PAGE-BUFFERS)
    (AS-1 (WITHOUT-INTERRUPTS (GET-DISK-RQB))
	  VM-PAGE-RQBS
	  C)
    (AS-1 (RQB-BUFFER (AR-1 VM-PAGE-RQBS C))
	  VM-PAGE-BUFFERS
	  C)
    (AS-1 0 VM-PAGE-AGES C)))

(DEFUN VM-WRITEOUT ()
  (DOTIMES (C VM-NUMBER-PAGE-BUFFERS)
    (VM-WRITE-OUT-PAGE C)))

(DEFUN VM-READ (ADR)
  (LET ((PAGE (LSH ADR -8))
	(IDX (LSH (LOGAND ADR 377) 1)))
    (DO ((C 0 (1+ C)))
	((= C VM-NUMBER-PAGE-BUFFERS)
	 (LET ((P (VM-FIND-LRU-PAGE)))
	   (VM-WRITE-OUT-PAGE P)
	   (VM-READ-IN P PAGE)
	   (AS-1 (SETQ VM-AGE (1+ VM-AGE)) VM-PAGE-AGES P)
	   (LET ((BUF (AR-1 VM-PAGE-BUFFERS P)))
	     (DPB (AR-1 BUF (1+ IDX)) 2020 (AR-1 BUF IDX)))))
      (COND ((EQ PAGE (AR-1 VM-PAGE-DISK-ADDRESSES C))
	     (AS-1 (SETQ VM-AGE (1+ VM-AGE)) VM-PAGE-AGES C)
	     (RETURN (LET ((BUF (AR-1 VM-PAGE-BUFFERS C)))
		       (DPB (AR-1 BUF (1+ IDX)) 2020 (AR-1 BUF IDX)))))))))

; RETURNS <DATA-TYPE> <ADR>
(DEFUN VM-READ-TYPED-POINTER (ADR)
 (PROG TOP NIL 
  (LET ((PAGE (LSH ADR -8))
	(IDX (LSH (LOGAND ADR 377) 1)))
    (DO ((C 0 (1+ C)))
	((= C VM-NUMBER-PAGE-BUFFERS)
	 (LET ((P (VM-FIND-LRU-PAGE)))
	   (VM-WRITE-OUT-PAGE P)
	   (VM-READ-IN P PAGE)
	   (AS-1 (SETQ VM-AGE (1+ VM-AGE)) VM-PAGE-AGES P)
	   (LET ((BUF (AR-1 VM-PAGE-BUFFERS P)))
	     (RETURN-FROM TOP (LDB 1005 (AR-1 BUF (1+ IDX)))
			      (%LOGDPB (AR-1 BUF (1+ IDX)) 2010 (AR-1 BUF IDX))))))
      (COND ((EQ PAGE (AR-1 VM-PAGE-DISK-ADDRESSES C))
	     (AS-1 (SETQ VM-AGE (1+ VM-AGE)) VM-PAGE-AGES C)
	     (LET ((BUF (AR-1 VM-PAGE-BUFFERS C)))
	       (RETURN-FROM TOP (LDB 1005 (AR-1 BUF (1+ IDX)))
			    (%LOGDPB (AR-1 BUF (1+ IDX)) 2010 (AR-1 BUF IDX))))))))))

(DEFUN VM-WRITE (ADR DATA)
  (LET ((PAGE (LSH ADR -8))
	(IDX (LSH (LOGAND ADR 377) 1)))
    (DO ((C 0 (1+ C)))
	((= C VM-NUMBER-PAGE-BUFFERS)
	 (LET ((P (VM-FIND-LRU-PAGE)))
	   (VM-WRITE-OUT-PAGE P)
	   (VM-READ-IN P PAGE)
	   (AS-1 (SETQ VM-AGE (1+ VM-AGE)) VM-PAGE-AGES P)
	   (LET ((BUF (AR-1 VM-PAGE-BUFFERS P)))
	     (AS-1 (LDB 0020 DATA) BUF IDX)
	     (AS-1 (LDB 2020 DATA) BUF (1+ IDX))
	     DATA)))
      (COND ((EQ PAGE (AR-1 VM-PAGE-DISK-ADDRESSES C))
	     (AS-1 (SETQ VM-AGE (1+ VM-AGE)) VM-PAGE-AGES C)
	     (LET ((BUF (AR-1 VM-PAGE-BUFFERS C)))
	       (AS-1 (LDB 0020 DATA) BUF IDX)
	       (AS-1 (LDB 2020 DATA) BUF (1+ IDX)))
	     (RETURN DATA))))))

;DATA may be a BIGNUM. BP may cross halfword boundaries.
(DEFUN VM-DPB (ADR DATA BP)
  (LET ((PAGE (LSH ADR -8))
	(IDX (LSH (LOGAND ADR 377) 1))
	(PP (LDB 0606 BP))
	(SS (LDB 0006 BP)))
    (DO ((C 0 (1+ C)))
	((= C VM-NUMBER-PAGE-BUFFERS)
	 (LET ((P (VM-FIND-LRU-PAGE)))
	   (VM-WRITE-OUT-PAGE P)
	   (VM-READ-IN P PAGE)
	   (AS-1 (SETQ VM-AGE (1+ VM-AGE)) VM-PAGE-AGES P)
	   (LET ((BUF (AR-1 VM-PAGE-BUFFERS P)))
	     (COND ((< PP 20)
		    (LET* ((SS1 (MIN SS (- 20 PP)))
			   (BP1 (DPB SS1 0006 BP)))
			  (AS-1 (DPB (LDB 0020 DATA)  ;ASSURE FIXNUM
				     BP1
				     (AR-1 BUF IDX))
				BUF
				IDX)
			  (SETQ SS (- SS SS1))
			  (SETQ PP 20)
			  (SETQ DATA (ASH DATA (MINUS SS1))))))
	       (SETQ PP (- PP 20))
	       (AS-1 (DPB (LDB 0020 DATA)
			  (DPB PP 0606 SS)
			  (AR-1 BUF (1+ IDX)))
		     BUF
		     (1+ IDX))
	     DATA)))
      (COND ((EQ PAGE (AR-1 VM-PAGE-DISK-ADDRESSES C))
	     (AS-1 (SETQ VM-AGE (1+ VM-AGE)) VM-PAGE-AGES C)
	     (LET ((BUF (AR-1 VM-PAGE-BUFFERS C)))
	       (COND ((< PP 20)
		      (LET* ((SS1 (MIN SS (- 20 PP)))
			     (BP1 (DPB SS1 0006 BP)))
			    (AS-1 (DPB (LDB 0020 DATA)  ;ASSURE FIXNUM
				       BP1
				       (AR-1 BUF IDX))
				  BUF
				  IDX)
			    (SETQ SS (- SS SS1))
			    (SETQ PP 20)
			    (SETQ DATA (ASH DATA (MINUS SS1))))))
		 (SETQ PP (- PP 20))
		 (AS-1 (DPB (LDB 0020 DATA)
			    (DPB PP 0606 SS)
			    (AR-1 BUF (1+ IDX)))
		       BUF
		       (1+ IDX)))
	     (RETURN DATA))))))

(DEFUN VM-WRITE-HALFWORDS (ADR HI LOW)
  (LET ((PAGE (LSH ADR -8))
	(IDX (LSH (LOGAND ADR 377) 1)))
    (DO ((C 0 (1+ C)))
	((= C VM-NUMBER-PAGE-BUFFERS)
	 (LET ((P (VM-FIND-LRU-PAGE)))
	   (VM-WRITE-OUT-PAGE P)
	   (VM-READ-IN P PAGE)
	   (AS-1 (SETQ VM-AGE (1+ VM-AGE)) VM-PAGE-AGES P)
	   (LET ((BUF (AR-1 VM-PAGE-BUFFERS P)))
	     (AS-1 LOW BUF IDX)
	     (AS-1 HI  BUF (1+ IDX))
	     DATA)))
      (COND ((EQ PAGE (AR-1 VM-PAGE-DISK-ADDRESSES C))
	     (AS-1 (SETQ VM-AGE (1+ VM-AGE)) VM-PAGE-AGES C)
	     (LET ((BUF (AR-1 VM-PAGE-BUFFERS C)))
	       (AS-1 LOW BUF IDX)
	       (AS-1 HI BUF (1+ IDX)))
	     (RETURN DATA))))))

(DEFUN VM-WRITE-TYPED-POINTER (ADR DT POINTER)
  (LET ((PAGE (LSH ADR -8))
	(IDX (LSH (LOGAND ADR 377) 1)))
    (DO ((C 0 (1+ C)))
	((= C VM-NUMBER-PAGE-BUFFERS)
	 (LET ((P (VM-FIND-LRU-PAGE)))
	   (VM-WRITE-OUT-PAGE P)
	   (VM-READ-IN P PAGE)
	   (AS-1 (SETQ VM-AGE (1+ VM-AGE)) VM-PAGE-AGES P)
	   (LET ((BUF (AR-1 VM-PAGE-BUFFERS P)))
	     (AS-1 (LDB 0020 POINTER) BUF IDX)
	     (AS-1 (DPB DT 1005 (LDB 2010 POINTER)) BUF (1+ IDX))
	     DATA)))
      (COND ((EQ PAGE (AR-1 VM-PAGE-DISK-ADDRESSES C))
	     (AS-1 (SETQ VM-AGE (1+ VM-AGE)) VM-PAGE-AGES C)
	     (LET ((BUF (AR-1 VM-PAGE-BUFFERS C)))
	       (AS-1 (LDB 0020 POINTER) BUF IDX)
	       (AS-1 (DPB DT 1005 (LDB 2010 POINTER)) BUF (1+ IDX)))
	     (RETURN DATA))))))

(DEFUN VM-WRITE-CDR-CODE (ADR CC)
  (LET ((PAGE (LSH ADR -8))
	(IDX (LSH (LOGAND ADR 377) 1)))
    (DO ((C 0 (1+ C)))
	((= C VM-NUMBER-PAGE-BUFFERS)
	 (LET ((P (VM-FIND-LRU-PAGE)))
	   (VM-WRITE-OUT-PAGE P)
	   (VM-READ-IN P PAGE)
	   (AS-1 (SETQ VM-AGE (1+ VM-AGE)) VM-PAGE-AGES P)
	   (LET ((BUF (AR-1 VM-PAGE-BUFFERS P)))
	     (AS-1 (DPB CC 1602 (AR-1 BUF (1+ IDX))) BUF (1+ IDX))
	     DATA)))
      (COND ((EQ PAGE (AR-1 VM-PAGE-DISK-ADDRESSES C))
	     (AS-1 (SETQ VM-AGE (1+ VM-AGE)) VM-PAGE-AGES C)
	     (LET ((BUF (AR-1 VM-PAGE-BUFFERS C)))
	       (AS-1 (DPB CC 1602 (AR-1 BUF (1+ IDX))) BUF (1+ IDX)))
	     (RETURN DATA))))))

(DEFUN VM-FIND-LRU-PAGE ()
  (PROG1 (DO ((C 0 (1+ C))
	      (LRU 0)
	      (LRUTM 20000000))
	     ((= C VM-NUMBER-PAGE-BUFFERS)
	      LRU)
	   (COND ((< (AR-1 VM-PAGE-AGES C) LRUTM)
		  (SETQ LRUTM (AR-1 VM-PAGE-AGES C))
		  (SETQ LRU C))))
	 (COND ((> VM-AGE 1000000)
		(VM-RESET-AGES)))))

(DEFUN VM-RESET-AGES NIL
  (DOTIMES (C VM-NUMBER-PAGE-BUFFERS)
    (AS-1 0 VM-PAGE-AGES C))
  (SETQ VM-AGE 0))

(DEFUN VM-WRITE-OUT-PAGE (I)
  (LET ((P (AR-1 VM-PAGE-DISK-ADDRESSES I)))
    (COND (P (DISK-WRITE (AR-1 VM-PAGE-RQBS I) VM-UNIT (+ P VM-PARTITION-BASE))))
    (AS-1 NIL VM-PAGE-DISK-ADDRESSES I)))

(DEFUN VM-READ-IN-PAGE (I P)
  (DISK-READ (AR-1 VM-PAGE-RQBS I) VM-UNIT (+ P VM-PARTITION-BASE))
  (AS-1 P VM-PAGE-DISK-ADDRESSES I))