;;;-*- Mode:LISP; Package:LISP-INTERNALS; Base:10; Readtable:CL -*-
;;;
;;; Written by Youcef Bennour.
;;;


(DEFPARAMETER sharestruct-ptr #xff000080)
(DEFPARAMETER sharestruct-lock #xff000084)
(DEFPARAMETER sharestruct-debug-level #xff000085)

(DEFCONSTANT sharestruct-share-lock 0)
(DEFCONSTANT sharestruct-max-iopbs-offset 4)
(DEFCONSTANT sharestruct-current-iopb-offset 8)
(DEFCONSTANT sharestruct-valid-table-offset 12.)

(DEFCONSTANT share-iopb-runme-offset 0)
(DEFCONSTANT share-iopb-slot-offset 4)
(DEFCONSTANT share-iopb-type-offset 8)
(DEFCONSTANT share-iopb-iopb-offset 12.)
(DEFCONSTANT share-iopb-interrupt-offset 16.)

(defun sharestruct-valid-p ()
  (not (zerop (hw:ldb (read-8086-multibus-address sharestruct-ptr) (byte 20. 0) 0)))
  )

; these are word addresses in mem-slot

(DEFPARAMETER lambda-share-iopb-structure #o520) ; see qcom
(DEFPARAMETER debug-program-share-iopb-structure #o540)

(defparameter share-lock-prevent-accidental-recursion nil)

(DEFPARAMETER enable-locking t)

;;; routines to support shared disk   -pace 3/21/84

(defun multibus-address-to-8086-ptr (adr)
  (hw:dpb-unboxed (hw:ldb adr (byte 16. 4) 0)
		  (byte 16. 16.)
		  (hw:ldb adr (byte 4. 0) 0))
  )

(defun 8086-ptr-to-multibus-address (ptr)
  (hw:dpb-unboxed #xff (byte 8. 24.)
		  (+ (ash (hw:ldb ptr (byte 16. 16.) 0) 4)
		     (hw:ldb ptr (byte 16. 0) 0)))
     )

(defun share-lock ()
  (cond ((or (null enable-locking)
;	     (typep *proc* 'local-access-path)
	     nil
	     )
	 )  ;we might take a page fault and hang!!
	((null share-lock-prevent-accidental-recursion)
	 (setq share-lock-prevent-accidental-recursion t)
;	 (with-timeout ((* 60. 5) (li:error "timeout waiting for share-lock"))
	   (do ()
	       ((zerop (nubus-stuff:%bus-byte-read sharestruct-lock))))
;	   )
	 (nubus-stuff:%bus-byte-write sharestruct-lock 1))
	(t
	 (li:error "share-lock called while cadr apparently already had lock"))))

(defun share-unlock ()
  (cond ((or (null enable-locking)
;	     (typep *proc* 'local-access-path)
	     nil
	     ))
	(t (setq share-lock-prevent-accidental-recursion nil)
	   (nubus-stuff:%bus-byte-write sharestruct-lock 0))))

(defun read-8086-multibus-address (nubus-pointer-location)
  (let ((multibus-address
	  (8086-ptr-to-multibus-address
	    (cond ((zerop (hw:ldb nubus-pointer-location #o0002 0))
		   (nubus-stuff:%bus-quad-slot-read-unsafe
			 (hw:ldb nubus-pointer-location (byte 8 24.) 0)
			 (hw:ldb nubus-pointer-location (byte 24. 0) (hw:unboxed-constant 0))))
		  (t
		   (logior (nubus-stuff:%bus-read-byte-unsafe nubus-pointer-location)
			   (ash (nubus-stuff:%bus-read-byte-unsafe
				      (+ nubus-pointer-location 1)) 8)
			   (ash (nubus-stuff:%bus-read-byte-unsafe
				      (+ nubus-pointer-location 2)) 16.)
			   (ash (nubus-stuff:%bus-read-byte-unsafe
				      (+ nubus-pointer-location 3)) 24.)))))))
    (values (nubus-stuff:map-multibus-address multibus-address) multibus-address)))


(defun print-share-iopbs (&optional print-iopbs)
  (format t "~&sharestruct-debug-level = ~d."
	  (nubus-stuff:%bus-byte-read sharestruct-debug-level))
  (format t "~&sharestruct-lock = ~o"
	  (nubus-stuff:%bys-byte-read sharestruct-lock))
  (share-lock)
  (unwind-protect
      (let ((sharestruct (read-8086-multibus-address sharestruct-ptr)))
	(format t "~&sharestruct = ~x" sharestruct)
	(cond ((zerop (hw:ldb sharestruct (byte 20. 0) 0))
	       (li:error "~&sharestruct pointer not set up yet")))
	(let ((maxiopbs (nubus-stuff:%bus-byte-read
			  (+ sharestruct sharestruct-max-iopbs-offset)))
	      (currentiopb (nubus-stuff:%bus-byte-read
			     (+ sharestruct sharestruct-current-iopb-offset))))
	  (format t "~&maxiopbs = ~d" maxiopbs)
	  (format t "~&currentiopb = ~d" currentiopb)
	  
	  (dotimes (n maxiopbs)
	    (let ((valid (nubus-stuff:%bus-read-byte-unsafe
			   (+ sharestruct sharestruct-valid-table-offset (* 4 n))))
		  (siopb (read-8086-multibus-address 
			   (+ sharestruct sharestruct-valid-table-offset
			      (* 4 maxiopbs) (* n 4)))))
	      (format t "~&slot ~d: (~x) valid = #x~x siopb = #x~x"
		      n
		      (+ sharestruct sharestruct-valid-table-offset (* 4 n))
		      valid siopb)
	      (cond ((not (zerop valid))
		     (print-share-iopb siopb print-iopbs)))))))
    (share-unlock)))

(defun print-share-iopb (adr &optional print-iopbs)
  (format t "~&~4tshare-iopb at ~o (#x~x)" adr adr)
  (format t "~&~8trunme = ~o"
	  (nubus-stuff:%bus-read-byte-unsafe (+ adr share-iopb-runme-offset)))
  (format t "~&~8tslot = ~o (#x~:*~x)"
	  (nubus-stuff:%bus-read-byte-unsafe (+ adr share-iopb-slot-offset)))
  (format t "~&~8ttype = ~o"
	  (nubus-stuff:%bus-read-byte-unsafe (+ adr share-iopb-type-offset)))
  (let ((iopb-address (read-8086-multibus-address (+ adr share-iopb-iopb-offset))))
    (format t "~&~8tiopb = ~o ~:* ~x" iopb-address)
    (if print-iopbs
	(print-iopb-at-nubus-address iopb-address)))
  (let ((inter-multi-loc
	  (read-8086-multibus-address (+ adr share-iopb-interrupt-offset))))
    (format t "~&~8tinterrupt = ~o (= nubus ~x)"
	    inter-multi-loc (map-multibus-address inter-multi-loc))))

(DEFCONSTANT cadr-share-slot #o377)
;	  (cond ((= si:processor-type-code si:cadr-type-code) #o377)
;		((= si:processor-type-code si:lambda-type-code)
;		 (cond ((not (boundp 'si:*my-op*)) #o376)
;		       (t (- #o375 (si:op-proc-number si:*my-op*)))))))

(DEFCONSTANT cadr-share-type #o300) ; #o377)

(defun remove-share-iopb (&optional (slot cadr-share-slot) (type cadr-share-type) (ask-p t))
  (share-lock)
  (unwind-protect
      (let ((sharestruct (read-8086-multibus-address sharestruct-ptr)))
	(cond ((zerop (hw:ldb sharestruct (byte 20. 0) 0))
	       (li:error "~&sharestruct pointer not set up yet")))
	(let ((maxiopbs (nubus-stuff:%bus-byte-read 
			  (+ sharestruct sharestruct-max-iopbs-offset))))
	  
	  (dotimes (n maxiopbs)
	    (let ((valid (nubus-stuff:%bus-byte-read
			   (+ sharestruct sharestruct-valid-table-offset (* 4 n))))
		  (siopb (read-8086-multibus-address 
			   (+ sharestruct sharestruct-valid-table-offset
			      (* maxiopbs 4) (* n 4)))))
	      (cond ((not (zerop valid))
		     (let ((this-slot (nubus-stuff:%bus-read-byte-unsafe
					    (+ siopb share-iopb-slot-offset)))
			   (this-type (nubus-stuff:%bus-read-byte-unsafe
					    (+ siopb share-iopb-type-offset))))
		       (cond ((and (or (= this-slot slot)
				       (= this-slot (logxor #xf0 slot)))
				   (= this-type type))
			      (nubus-stuff:%bus-byte-write
				    (+ sharestruct sharestruct-valid-table-offset
				       (* n 4)) 0)))
		       (when (not (member (hw:ldb this-slot (byte 4 4) 0)
					'(0 1 #xe #xf) :test :eq))
			 (print-share-iopb siopb)
			 (if (if ask-p (y-or-n-p "Flush this IOPB ")
;			       (format t "Flushing this IOPB ")
			       t)
			     (nubus-stuff:%bus-byte-write
				   (+ sharestruct sharestruct-valid-table-offset
				      (* n 4)) 0))))))))))
    (share-unlock))
  )

(defun invalidate-slot (slot-number)
  (share-lock)
  (unwind-protect
      (let ((sharestruct (read-8086-multibus-address sharestruct-ptr)))
	(cond ((zerop (hw:ldb sharestruct (byte 20. 0) 0))
	       (li:error "sharestruct not set up yet")))
	(let ((maxiopbs (nubus-stuff:%bus-byte-read
			      (+ sharestruct sharestruct-max-iopbs-offset))))
	  (cond ((>= slot-number maxiopbs)
		 (li:error "there are only ~d slots" maxiopbs)))
	  (nubus-stuff:%bus-write (+ sharestruct sharestruct-valid-table-offset
				     (* slot-number 4)) 0)))
    (share-unlock)))

(defun insert-share-iopb ()
  (remove-share-iopb cadr-share-slot cadr-share-type nil)
  (let ((prime-memory-adr ;(+ (ash (cadr (car (P-memory-configuration-list *proc*))) 10.)
			     ;;(dpb (SEND *PROC* :MEM-SLOT) (byte 4 24.) #xf0000000)
			   ;  (* debug-program-share-iopb-structure 4))))
	  *buffer-area*))
;    (format t "~%prime-memory-adr for iopb=#x~x" prime-memory-adr)
    (nubus-stuff:%bus-write (+ prime-memory-adr share-iopb-runme-offset) 0)
    (nubus-stuff:%bus-write (+ prime-memory-adr share-iopb-slot-offset) cadr-share-slot)
    (nubus-stuff:%bus-write (+ prime-memory-adr share-iopb-type-offset) cadr-share-type)
    
    ;;set up pointer from share-iopb to real iopb
    ;;like the old code, use 650 in virtual address space for iopb, and point
    ;; to it with our multibus mapping reg
    (nubus-stuff:write-multibus-mapping-register k-multibus-mapping-register-base
				     (+ #x800000 (cadr-page-to-nubus-page 1)))
    (nubus-stuff:%bus-write (+ prime-memory-adr share-iopb-iopb-offset)
		  (multibus-address-to-8086-ptr
		    (+ (ash k-multibus-mapping-register-base 10.) (* #o250 4))))
    
    ;;no interrupts
    (nubus-stuff:%bus-write (+ prime-memory-adr share-iopb-interrupt-offset) 0)
    
    (share-lock)
    (unwind-protect
	(let ((sharestruct (read-8086-multibus-address sharestruct-ptr)))
	  (cond ((zerop (hw:ldb sharestruct (byte 20. 0) 0))
		 (li:error "~&sharestruct pointer not set up yet")))
	  (let ((maxiopbs (nubus-stuff:%bus-byte-read 
			    (+ sharestruct sharestruct-max-iopbs-offset))))
	    
	    (dotimes (n maxiopbs (li:error "out of iopb slots"))
	      (cond ((zerop (nubus-stuff:%bus-byte-read 
			      (+ sharestruct sharestruct-valid-table-offset (* 4 n))))
		     (nubus-stuff:%bus-write
		       (+ sharestruct sharestruct-valid-table-offset
			  (* 4 maxiopbs) (* 4 n))
		       (multibus-address-to-8086-ptr
			 (+ (ash k-multibus-mapping-register-base 10.) (* #o140 4))))
		     (nubus-stuff:%bus-byte-write
		       (+ sharestruct sharestruct-valid-table-offset (* 4 n)) 1)
		     (return nil))))))
      (share-unlock)))
  )

(DEFCONSTANT multibus-interrupt-1 #xff01c1e4)
(DEFCONSTANT multibus-interrupt-7 #xff01c1fc)

(DEFPARAMETER share-trace nil)

(defun share-go ()
;  (if share-trace (send standard-output ':tyo #/g))
  (let ((prime-memory-adr (+ (ash (cadr (car (P-memory-configuration-list *proc*))) 10.)
			     ;(dpb (SEND *PROC* :MEM-SLOT) (byte 4 24.) #xf0000000)
			     (* debug-program-share-iopb-structure 4))))
    (nubus-stuff:%bus-byte-write (+ prime-memory-adr share-iopb-runme-offset) 1)
    (nubus-stuff:%bus-byte-write multibus-interrupt-7 1)))

(defun share-go-slot (slot-num)
  (share-lock)
  (unwind-protect
      (let ((sharestruct (read-8086-multibus-address sharestruct-ptr)))
	(format t "~&sharestruct = ~x" sharestruct)
	(cond ((zerop (hw:ldb sharestruct (byte 20. 0) 0))
	       (li:error "~&sharestruct pointer not set up yet")))
	(let ((maxiopbs (nubus-stuff:%bus-byte-read
			  (+ sharestruct sharestruct-max-iopbs-offset)))
	      (currentiopb (nubus-stuff:%bus-byte-read
			     (+ sharestruct sharestruct-current-iopb-offset))))
	  (format t "~&maxiopbs = ~d" maxiopbs)
	  (format t "~&currentiopb = ~d" currentiopb)
	  
	  (dotimes (n maxiopbs)
	    (let ((valid (nubus-stuff:%bus-read-byte-unsafe
			   (+ sharestruct sharestruct-valid-table-offset (* 4 n))))
		  (siopb (read-8086-multibu s-address 
			   (+ sharestruct sharestruct-valid-table-offset
			      (* 4 maxiopbs) (* n 4)))))
	      (format t "~&slot ~d: (~x) valid = #x~x siopb = #x~x"
		      n
		      (+ sharestruct sharestruct-valid-table-offset (* 4 n))
		      valid siopb)
	      (cond ((not (zerop valid))
		     (print-share-iopb siopb t)))
	      (cond ((and (= n slot-num)
			  (yes-or-no-p "Goose this one?"))
		     (nubus-stuff:%bus-write-byte-unsafe (+ siopb share-iopb-runme-offset) 1)))))))
    (share-unlock)))