;;;-*- Mode:LISP; Package:SYSTEM-INTERNALS; Readtable:ZL; Base:8; Lowercase:T -*- (defstruct (interphase-iopb (:type :array) (:constructor nil) (:conc-name ip-iopb-) ) command options status error unit head cylinder-hi cylinder-lo block-hi block-lo nblocks-hi nblocks-lo dma-count dma-adr-hi dma-adr-med dma-adr-lo io-adr-hi io-adr-lo relative-adr-hi relative-adr-lo reserved linked-iopb-hi linked-iopb-med linked-iopb-lo ) (defun make-interphase-iopb () (make-wireable-array 1 :art-8b 'interphase-iopb)) (defun build-interphase-command (iopb unit command byte-count disk-address &optional (byte-offset 0) ) (let ((page-status (%page-status iopb))) (cond ((null page-status) (ferror nil "iopb is swapped out!!")) ((not (= (ldb %%pht1-swap-status-code page-status) %pht-swap-status-wired)) (ferror nil "iopb is not wired!!")))) (when (not (zerop (ldb (byte 10. 0) byte-count))) (ferror nil "byte count must be even number of pages")) (setf (ip-iopb-command iopb) command) (setf (ip-iopb-options iopb) #o21) (setf (ip-iopb-status iopb) 0) (setf (ip-iopb-error iopb) 0) (setf (ip-iopb-unit iopb) unit) (multiple-value-bind (head cylinder sector) (convert-block-to-disk-physical disk-address) (setf (ip-iopb-head iopb) head) (setf (ip-iopb-cylinder-hi iopb) (ldb (byte 8 8) cylinder)) (setf (ip-iopb-cylinder-lo iopb) (ldb (byte 8 0) cylinder)) (setf (ip-iopb-block-hi iopb) (ldb (byte 8 8) sector)) (setf (ip-iopb-block-lo iopb) (ldb (byte 8 0) sector))) (let ((blocks (truncate byte-count 1024.))) (setf (ip-iopb-nblocks-hi iopb) (ldb (byte 8 8) blocks)) (setf (ip-iopb-nblocks-lo iopb) (ldb (byte 8 0) blocks))) (setf (ip-iopb-dma-count iopb) 64.) (let ((io-adr #o100)) (setf (ip-iopb-io-adr-hi iopb) (ldb (byte 8 8) io-adr)) (setf (ip-iopb-io-adr-lo iopb) (ldb (byte 8 0) io-adr))) (setf (ip-iopb-relative-adr-hi iopb) 0) (setf (ip-iopb-relative-adr-lo iopb) 0) (setf (ip-iopb-reserved iopb) 0) (setf (ip-iopb-linked-iopb-hi iopb) 0) (setf (ip-iopb-linked-iopb-med iopb) 0) (setf (ip-iopb-linked-iopb-lo iopb) 0) dma-adr-hi dma-adr-med dma-adr-lo (defun build-iopb (iopb-base-address command unit head cylinder starting-sector number-of-sectors dma-count buffer-memory-address &optional (fctn 'write-iopb)) (FUNCALL FCTN 0 command) (FUNCALL FCTN 1 word-mode-option) ;command options (FUNCALL FCTN 2 0) ;reset status (FUNCALL FCTN 3 0) ;reset errors (FUNCALL FCTN 4 unit) ;unit select (FUNCALL FCTN 5 head) ;head select (FUNCALL FCTN 6 (ldb 1010 cylinder)) ;cylinder select [high byte] (FUNCALL FCTN 7 (ldb 0010 cylinder)) ;cylinder select [low byte] (FUNCALL FCTN 10 (ldb 1010 starting-sector)) ;high byte (FUNCALL FCTN 11 (ldb 0010 starting-sector)) ;low byte (FUNCALL FCTN 12 (ldb 1010 number-of-sectors)) ;sector count [high byte] (FUNCALL FCTN 13 (ldb 0010 number-of-sectors)) ;sector count [low byte] (FUNCALL FCTN 14 dma-count) ;dma count (let ((buf (if (listp buffer-memory-address) (car buffer-memory-address) (multibus-real-address buffer-memory-address)))) (FUNCALL FCTN 15 (ldb 2010 buf)) ;buffer [data] address (FUNCALL FCTN 16 (ldb 1010 buf)) (FUNCALL FCTN 17 (ldb 0010 buf))) (FUNCALL FCTN 20 (ldb 1010 disk-base-reg-address)) ;must be the same as that set by switch (FUNCALL FCTN 21 (ldb 0010 disk-base-reg-address)) (FUNCALL FCTN 22 0) ;relative address irrelevent in (FUNCALL FCTN 23 0) ; absolute addressing mode (FUNCALL FCTN 24 0) ;reserved (FUNCALL FCTN 25 0) ;no linked iopbs [XMB] (FUNCALL FCTN 26 0) ;no linked iopbs [MSB] (FUNCALL FCTN 27 0)) (defun read-random-block (cylinder head sector) (set-iopb-pointer iopb-base-address) (build-iopb iopb-base-address smd-read-command default-unit head cylinder sector 1 ;one sector 2 ;dma-count 2000) ;buffer area address (disk-go-command) (wait-for-iopb-completion) (let* ((mb-word-base 2000)) (dotimes (x 8) (format t "~&") (if *verbose? (dotimes (y 16.) (format t "~3o " (multibus-byte-read (+ mb-word-base (+ (* x 16.) y)) t)))) (dotimes (y 16.) (format t "~c" (multibus-byte-read (+ mb-word-base (+ (* x 16.) y)) t)))))) (defun write-random-block (cylinder head sector list-of-words) (let* ((mb-adr-base 2000) (mb-word-base (// mb-adr-base 4))) (do ((l list-of-words (cdr l)) (word-number 0 (1+ word-number))) ((null l)) (multibus-write-32 (+ word-number mb-word-base) (car l))) (set-iopb-pointer iopb-base-address) (build-iopb iopb-base-address smd-write-command default-unit head cylinder sector 1 ;one sector 2 ;dma-count mb-adr-base) ;buffer area address (disk-go-command) (wait-for-iopb-completion))) (defun decode-logical-block (block) (let* ((b-per-t sectors-per-track) (b-per-c (* b-per-t heads-per-cylinder)) (cylinder (// block b-per-c)) (head (// (- block (* cylinder b-per-c)) b-per-t)) (block-within-track (- block (+ (* cylinder b-per-c) (* head b-per-t))))) (values cylinder head block-within-track))) (defun read-logical-block (block) (multiple-value-bind (cylinder head sector) (decode-logical-block block) (read-random-block cylinder head sector))) (defun write-logical-block (block data) (multiple-value-bind (cylinder head sector) (decode-logical-block block) (write-random-block cylinder head sector data))) (defun map-logical-blocks (start count &optional data) (do ((j 0 (1+ j))) ((= j count)) (if data (write-logical-block (+ start j) data) (read-logical-block (+ start j))))) (defun number-of-logical-blocks () (* sectors-per-track heads-per-cylinder TRACKS-PER-DRIVE)) (defun random-logical-blocks (&optional data) (let ((n (random (number-of-logical-blocks)))) (multiple-value-bind (cylinder head sector) (decode-logical-block n) (format t "~&; Block = ~D. CYL = ~D HEAD = ~D SECTOR = ~D~%" n cylinder head sector)) (if data (write-logical-block n data)) (read-logical-block n))) ;mini-label is stored in block 22, which, with 512 byte sectors, is sector 0 of head 1, ; with 1024 byte sectors, it is sector 22. of head 0. ; cylinder 0. Format is: ; word 0: check ascii FOOB ; word 1: name ascii LISP ; word 2: cylinder offset ; word 3: length in cylinders ; word 4: -1 ;(in the future, words 1-3 can be repeated). ; this uses mbus location 2000 as a buffer ; (which is then offset by multibus offset hack) (defun lam-read-mini-label (name) name (cond ((null (send *proc* :disk-share-mode)) ;*use-configuration-structure* (write-multibus-mapping-register lam-multibus-mapping-register-base (+ 1_23. 17_18. (LSH (SEND *PROC* :MEM-SLOT) 14.) 1 )) (set-iopb-pointer (+ (ash lam-multibus-mapping-register-base 10.) (* 250 4)) nil) ;byte adr within page. (build-iopb-in-nubus-memory 650 ;iopb-base-address smd-read-command default-unit (if (< sectors-per-track 23.) 1 0) ;head 0 0 ;cylinder 0 (if (< sectors-per-track 23.) (- 22. sectors-per-track) 22.) ;starting sector 1 ;one sector 2 ;dma-count 102000) ;buffer area address (disk-go-command) (wait-for-iopb-completion-nubus 650) (cond ((or (not (= (multibus-byte-read 102000) #/F)) (not (= (multibus-byte-read 102001) #/O)) (not (= (multibus-byte-read 102002) #/O)) (not (= (multibus-byte-read 102003) #/B))) (ferror nil "mini-label check word doesn't check")) ((or (not (= (multibus-byte-read 102004) #/L)) (not (= (multibus-byte-read 102005) #/I)) (not (= (multibus-byte-read 102006) #/S)) (not (= (multibus-byte-read 102007) #/P))) (ferror nil "can't find LISP mini label partition"))) (setq *lam-disk-cylinder-offset* (funcall *proc* :bus-quad-slot-read sdu-quad-slot (ash 102010 -2)))) ((typep *proc* 'lambda-via-local-access) ;we're really the same machine, so we can read it directly! (let* ((rqb (si:get-disk-rqb)) (rqb-string (si:rqb-8-bit-buffer rqb))) (si:disk-read-physical rqb default-unit 22.) (cond ((or (not (= (aref rqb-string 0) #/F)) (not (= (aref rqb-string 1) #/O)) (not (= (aref rqb-string 2) #/O)) (not (= (aref rqb-string 3) #/B))) (ferror nil "mini-label check word doesn't check")) ((or (not (= (aref rqb-string 4) #/L)) (not (= (aref rqb-string 5) #/I)) (not (= (aref rqb-string 6) #/S)) (not (= (aref rqb-string 7) #/P))) (ferror nil "can't find LISP mini label partition"))) (setq *lam-disk-cylinder-offset* (+ (ash (aref rqb-string 11) 8) (aref rqb-string 10))) (si:return-disk-rqb rqb))) (t (let ((his-version (or *his-version* his-system-version-override (QF-POINTER (phys-mem-read (+ 400 %SYS-COM-MAJOR-VERSION)))))) (cond ((>= his-version 104.) ;use wired-disk-buffer (let ((wired-disk-buffer (qf-initial-area-origin 'wired-disk-buffer))) (multiple-value-bind (sys-com-quad-slot sys-com-rel-adr) (cadr-adr-to-nubus-quad-slot-and-rel-adr 650) (write-multibus-mapping-register lam-multibus-mapping-register-base (+ 1_23. (LSH sys-com-quad-slot 14.) (ash sys-com-rel-adr -8))) (set-iopb-pointer (+ (ash lam-multibus-mapping-register-base 10.) (* (logand sys-com-rel-adr 377) 4)) nil) ;byte adr within page. (multiple-value-bind (disk-buffer-quad-slot disk-buffer-rel-adr) (cadr-adr-to-nubus-quad-slot-and-rel-adr wired-disk-buffer) (write-multibus-mapping-register (1+ lam-multibus-mapping-register-base) (+ 1_23. (lsh disk-buffer-quad-slot 14.) (ash disk-buffer-rel-adr -8))) (build-iopb-in-nubus-memory 650 ;iopb-base-address smd-read-command default-unit (if (< sectors-per-track 23.) 1 0) ;head 0 0 ;cylinder 0 (if (< sectors-per-track 23.) (- 22. sectors-per-track) 22.) ;starting sector 1 ;one sector 2 ;dma-count (ASH (1+ lam-multibus-mapping-register-base) 10.)) ;buffer area address (disk-go-command) (wait-for-iopb-completion-nubus 650) (cond ((or (not (= (funcall *proc* :bus-quad-slot-read-byte disk-buffer-quad-slot (+ (ash disk-buffer-rel-adr 2) 0)) #/F)) (not (= (funcall *proc* :bus-quad-slot-read-byte disk-buffer-quad-slot (+ (ash disk-buffer-rel-adr 2) 1)) #/O)) (not (= (funcall *proc* :bus-quad-slot-read-byte disk-buffer-quad-slot (+ (ash disk-buffer-rel-adr 2) 2)) #/O)) (not (= (funcall *proc* :bus-quad-slot-read-byte disk-buffer-quad-slot (+ (ash disk-buffer-rel-adr 2) 3)) #/B))) (ferror nil "mini-label check word doesn't check")) ((or (not (= (funcall *proc* :bus-quad-slot-read-byte disk-buffer-quad-slot (+ (ash disk-buffer-rel-adr 2) 4)) #/L)) (not (= (funcall *proc* :bus-quad-slot-read-byte disk-buffer-quad-slot (+ (ash disk-buffer-rel-adr 2) 5)) #/I)) (not (= (funcall *proc* :bus-quad-slot-read-byte disk-buffer-quad-slot (+ (ash disk-buffer-rel-adr 2) 6)) #/S)) (not (= (funcall *proc* :bus-quad-slot-read-byte disk-buffer-quad-slot (+ (ash disk-buffer-rel-adr 2) 7)) #/P))) (ferror nil "can't find LISP mini label partition"))) (setq *lam-disk-cylinder-offset* (funcall *proc* :bus-quad-slot-read disk-buffer-quad-slot (+ (ash disk-buffer-rel-adr 2) 10))) )))) (t (setq *lam-disk-cylinder-offset* 100.) (format t "~%asumming mini label since to memory available to read it into!!!") ))))) ;foo no memory to read it into (format t "~&Setting LISP disk cylinder offset to ~D." *lam-disk-cylinder-offset*)) ;;status register: bit 0 : BUSY ;; 1 : OPERATION DONE ;; 2 : STATUS CHANGE INTERRUPT - for polled interrupt systems ;; 3 : unused ;; 4 : UNIT 1 READY ;; 5 : UNIT 2 READY ;; 6 : UNIT 3 READY ;; 7 : UNIT 4 READY (defun read-disk-status () (cond ((null (send *proc* :disk-share-mode)) (multibus-io-read-8 disk-base-reg-address)) (t (ferror nil "can't call this in share mode")))) (defconst word-mode-option 21) ;sets word mode for data (defun build-iopb (iopb-base-address command unit head cylinder starting-sector number-of-sectors dma-count buffer-memory-address &optional (fctn 'write-iopb)) (FUNCALL FCTN 0 command) (FUNCALL FCTN 1 word-mode-option) ;command options (FUNCALL FCTN 2 0) ;reset status (FUNCALL FCTN 3 0) ;reset errors (FUNCALL FCTN 4 unit) ;unit select (FUNCALL FCTN 5 head) ;head select (FUNCALL FCTN 6 (ldb 1010 cylinder)) ;cylinder select [high byte] (FUNCALL FCTN 7 (ldb 0010 cylinder)) ;cylinder select [low byte] (FUNCALL FCTN 10 (ldb 1010 starting-sector)) ;high byte (FUNCALL FCTN 11 (ldb 0010 starting-sector)) ;low byte (FUNCALL FCTN 12 (ldb 1010 number-of-sectors)) ;sector count [high byte] (FUNCALL FCTN 13 (ldb 0010 number-of-sectors)) ;sector count [low byte] (FUNCALL FCTN 14 dma-count) ;dma count (let ((buf (if (listp buffer-memory-address) (car buffer-memory-address) (multibus-real-address buffer-memory-address)))) (FUNCALL FCTN 15 (ldb 2010 buf)) ;buffer [data] address (FUNCALL FCTN 16 (ldb 1010 buf)) (FUNCALL FCTN 17 (ldb 0010 buf))) (FUNCALL FCTN 20 (ldb 1010 disk-base-reg-address)) ;must be the same as that set by switch (FUNCALL FCTN 21 (ldb 0010 disk-base-reg-address)) (FUNCALL FCTN 22 0) ;relative address irrelevent in (FUNCALL FCTN 23 0) ; absolute addressing mode (FUNCALL FCTN 24 0) ;reserved (FUNCALL FCTN 25 0) ;no linked iopbs [XMB] (FUNCALL FCTN 26 0) ;no linked iopbs [MSB] (FUNCALL FCTN 27 0)) (defun build-iopb-in-nubus-memory (nubus-base-address command unit head cylinder starting-sector number-of-sectors dma-count buffer-memory-address) (build-iopb (* 4 nubus-base-address) command unit head cylinder starting-sector number-of-sectors dma-count (list buffer-memory-address) 'write-iopb-to-nubus)) (defun read-iopb-status (&optional (fctn 'read-iopb)) (funcall fctn 2)) (defun read-iopb-error (&optional (fctn 'read-iopb)) (funcall fctn 3)) (defun read-iopb-cylinder (&optional (fctn 'read-iopb)) (dpb (funcall fctn 6) 1010 (funcall fctn 7))) (defun read-iopb-number-of-sectors (&optional (fctn 'read-iopb)) (dpb (funcall fctn 12) 1010 (funcall fctn 13))) (defun read-iopb-memory-address (&optional (fctn 'read-iopb)) (dpb (funcall fctn 15) 2010 (dpb (funcall fctn 16) 1010 (funcall fctn 17)))) (defun read-next-iopb-address (&optional (fctn 'read-iopb)) (dpb (funcall fctn 25) 2010 (dpb (funcall fctn 26) 1010 (funcall fctn 27)))) (defun read-iopb-starting-sector (&optional (fctn 'read-iopb)) (dpb (funcall fctn 10) 1010 (funcall fctn 11))) (defun read-iopb-controller-io-address (&optional (fctn 'read-iopb)) (dpb (funcall fctn 20) 1010 (funcall fctn 21))) (defun print-lambda-iopb () (multiple-value-bind (quad-slot rel-adr) (cadr-adr-to-nubus-quad-slot-and-rel-adr 640) (let ((nubus-adr (dpb quad-slot (byte 8 24.) (* rel-adr 4)))) (format t "~%IOPB at phys adr ~s(~16r)" nubus-adr nubus-adr))) (print-iopb (* 4 640) 'read-iopb-from-nubus)) (DEFUN PRINT-DEBUG-NUBUS-IOPB () (PRINT-IOPB (* 4 650) 'READ-IOPB-FROM-NUBUS)) (DEFUN LAMBDA-IOPB-NUMBER-OF-SECTORS () (LET ((IOPB-BASE-ADDRESS (* 4 640))) (READ-IOPB-NUMBER-OF-SECTORS 'READ-IOPB-FROM-NUBUS))) (defun lambda-iopb-memory-address () (LET ((IOPB-BASE-ADDRESS (* 4 640))) (READ-IOPB-MEMORY-ADDRESS 'READ-IOPB-FROM-NUBUS))) (DEFUN READ-IOPB-FROM-NUBUS (ADDRESS-WITHIN-IOPB) (LET ((WD (phys-mem-read (LSH (+ IOPB-BASE-ADDRESS ADDRESS-WITHIN-IOPB) -2)))) (LDB (BYTE 8 (* (LOGAND ADDRESS-WITHIN-IOPB 3) 8)) WD))) (DEFUN WRITE-IOPB-TO-NUBUS (ADDRESS-WITHIN-IOPB DATA) (LET* ((WD (phys-mem-read (LSH (+ IOPB-BASE-ADDRESS ADDRESS-WITHIN-IOPB) -2)))) (SETQ WD (DPB DATA (BYTE 8 (* (LOGAND ADDRESS-WITHIN-IOPB 3) 8)) WD)) (phys-mem-write (LSH (+ IOPB-BASE-ADDRESS ADDRESS-WITHIN-IOPB) -2) WD)) ) (defun print-iopb-at-nubus-address (nubus-address) (print-iopb nil #'(lambda (x) (ldb 0010 (send *proc* :bus-read-byte (+ nubus-address x)))))) (defun print-iopb (&optional (iopb-base-address iopb-base-address) (fctn 'read-iopb)) (print-ip-error (funcall fctn 3)) (format t "~% command: ~o" (funcall fctn 0)) (format t " ~a" (selectq (funcall fctn 0) (#x81 "read") (#x82 "write") (#x83 "verify") (#x84 "format track") (#x85 "map") (#x87 "initialize") (#x89 "restore") (#x8a "seek") (#x8f "reset") (#x91 "direct read") (#x92 "direct write") (#x93 "read absolute"))) (format t "~% command options: ~o" (funcall fctn 1)) (format t "~% status: ~o" (funcall fctn 2)) (selectq (funcall fctn 2) (0 (format t " (controller hasn't seen it yet)")) (#x80 (format t " (operation successful)")) (#x81 (format t " (operation in progress)")) (#x82 (format t " (error)")) (t (format t " where did this number come from??"))) (format t "~% errors: ~o" (funcall fctn 3)) (format t "~% unit: ~o" (funcall fctn 4)) (format t "~% head: ~o" (funcall fctn 5)) (format t "~% cylinder: ~o" (read-iopb-cylinder fctn)) (format t "~% starting sector: ~o" (read-iopb-starting-sector fctn)) (format t "~% number of sectors: ~o" (read-iopb-number-of-sectors fctn)) (format t "~% dma count: ~o" (funcall fctn 14)) (format t "~%buffer memory address: ~o, page ~o" (read-iopb-memory-address fctn) (ash (read-iopb-memory-address fctn) -10.)) (print-multibus-mapping-register (ash (read-iopb-memory-address fctn) -10.)) (format t "~%controller io address: ~o" (read-iopb-controller-io-address fctn)) (format t "~% next iopb address: ~o" (read-next-iopb-address fctn)) (format t "~%")) ;;available disk commands: (defconst smd-read-command 201) ;81 hex (defconst smd-write-command 202) ;82 hex (defconst smd-verify-command 203) ;83 hex (defconst smd-format-track-command 204) ;84 hex (defconst smd-map-command 205) ;85 hex (defconst smd-report-configuration-command 206) ;86 hex (defconst smd-initialize-command 207) ;87 hex (used on power up and after reset) (defconst smd-restore-command 211) ;89 hex (defconst smd-seek-command 212) ;8A hex (defconst smd-zero-sector-command 213) ;8B hex (defconst smd-reset-command 217) ;8F hex (defconst smd-read-direct-command 221) ;91 hex (use with caution) (defconst smd-write-direct-command #x92) ;92 hex (use with caution) (defconst smd-read-absolute #x93) ;2190 only (defconst smd-read-non-cached #x94) ;2190 only ;; possible status codes (defconst smd-op-ok 200 "operation successful, ready for next") ;80 hex (defconst smd-busy 201 "operation in progress") ;81 hex (defconst smd-error 202 "error on last command") ;82 hex ;these set up for eagle for use during formatting only. (defconst sectors-per-track 25.) ;1024 byte sectors (defconst heads-per-cylinder 20.) (DEFCONST TRACKS-PER-DRIVE 842.) (defprop eagle setup-for-eagle setup-disk) (defun setup-for-eagle () (format t "~&Setting up for eagle") (setq lambda-disk-type 'eagle) (setq sectors-per-track 25.) (setq heads-per-cylinder 20.) (SETQ TRACKS-PER-DRIVE 842.)) (defprop unknown setup-for-unknown setup-disk) (defun setup-for-unknown () ;dont do it now since machine may be running. (format t "~&will read label to determine disk type") (setq n-heads nil n-blocks-per-track nil sectors-per-track nil heads-per-cylinder nil tracks-per-drive nil)) (defun really-setup-for-unknown () (format t "~&Reading label to determine disk type") (setq sectors-per-track 25. ;should only try to read blocks 0 and 1 using these. heads-per-cylinder 20. tracks-per-drive 842.) (read-label) (cond ((and (= n-heads 20.) (= n-blocks-per-track 25.)) (format t "~%Disk is EAGLE.") (setup-for-eagle)) ((and (= n-heads 19.) (= n-blocks-per-track 18.)) (format t "~%Disk is T302") (setup-for-t302)) ((and (= n-heads 24.) (= n-blocks-per-track 26.)) (format t "~%Disk is CDC 500") (funcall (get 'cdc-500 'setup-disk))) (t (Ferror nil "Disk type unknown. Do setup for it and return."))) ) (defprop t302 setup-for-t302 setup-disk) (defun setup-for-t302 () (format t "~&Setting up for T302") (setq lambda-disk-type 't302) (setq sectors-per-track 18.) (setq heads-per-cylinder 19.) (SETQ TRACKS-PER-DRIVE 800.)) (defprop local setup-for-local setup-disk) (defun setup-for-local () (setq lambda-disk-type 'local) (setq sectors-per-track (aref si:disk-sectors-per-track-array 0) heads-per-cylinder (aref si:disk-heads-per-cylinder-array 0) tracks-per-drive 842.) ;** no check here for now. (format t "~&Setting up for local disk, ~D sectors per track, ~D heads." sectors-per-track heads-per-cylinder)) (DEFVAR *GENERIC-DISK-PROPERTIES* ()) (DEFUN GETDISKP (PROP-NAME &OPTIONAL (DEFAULT NIL DEFAULTP)) (LET ((CELL (GET *GENERIC-DISK-PROPERTIES* PROP-NAME))) (COND (CELL cell) (DEFAULTP DEFAULT) (T (FERROR NIL "No ~S property specified for disk type ~S" prop-name (generic-disk-type)))))) (defun generic-disk-type () (car *GENERIC-DISK-PROPERTIES*)) (defun generic-disk-name () (getdiskp ':name (generic-disk-type))) (DEFUN SETUP-FOR-GENERIC-DISK () (FORMAT T "~&Setting up for ~A" (generic-disk-name)) (setq lambda-disk-type (generic-disk-type)) (setq sectors-per-track (getdiskp ':SECTORS-PER-TRACK)) ;; this is sort of the number of virtual platters. (setq heads-per-cylinder (getdiskp ':HEADS-PER-CYLINDER)) (SETQ TRACKS-PER-DRIVE (getdiskp ':CYLINDERS-PER-HEAD))) (DEFUN DEFINE-GENERIC-DISK (*GENERIC-DISK-PROPERTIES*) (PUTPROP (CAR *GENERIC-DISK-PROPERTIES*) (CLOSURE '(*GENERIC-DISK-PROPERTIES*) 'SETUP-FOR-GENERIC-DISK) 'SETUP-DISK) (PUTPROP (CAR *GENERIC-DISK-PROPERTIES*) (CLOSURE '(*GENERIC-DISK-PROPERTIES*) 'INITIALIZE-GENERIC-DISK) 'INITIALIZE-DISK)) (DEFINE-GENERIC-DISK '(CDC-500 :SECTORS-PER-TRACK 26. :HEADS-PER-CYLINDER 24. :CYLINDERS-PER-HEAD 711. :BYTES-PER-SECTOR 1024. :GAP1 28. :GAP2 28. :INTERLEAVE 3. :RETRY-COUNT 3. :SPIRAL-SKEW-factor 6. :DUAL-PORT 0)) (DEFCONST IP-ERROR-CODES-ALIST '((0 . "everything ok, or the controller hasn't looked yet") (#16R10 . "disk-not-ready") (#16R11 . "invalid disk address") (#16R12 . "seek error") (#16R13 . "ecc code error-data field") (#16R14 . "invalid command code") (#16R15 . "/"unused/"") (#16R16 . "invalid sector in command") (#16R17 . "/"spare/"") (#16R18 . "bus timeout") (#16R19 . "/"not used/"") (#16R1A . "disk write-proctected") (#16R1B . "unit not selected") (#16R1C . "no address mark - header field") (#16R1D . "/"not used/"") (#16R1E . "drive faulted") (#16R1F . "/"not used/"") (#16R20 . "/"not used/"") (#16R21 . "/"not used/"") (#16R22 . "/"not used/"") (#16R23 . "uncorrectable error") (#16R24 . "/"spare/"") (#16R25 . "/"spare/"") (#16R26 . "no sector pulse") (#16R27 . "data overrun") (#16R28 . "no index pulse on write format") (#16R29 . "sector not found") (#16R2A . "id field error-wrong head") (#16R2B . "invalid sync in data field") (#16R2D . "seek timeout error") (#16R2E . "busy timeout") (#16R2F . "not on cylinder") (#16R30 . "rtz timeout") (#16R31 . "format overrun on data") (#16R40 . "unit not initialized") (#16R42 . "gap specification error") (#16R4B . "seek error") (#16R4C . "mapped header error") (#16R50 . "sector per track error in UIB, 2190 only") (#16R51 . "bytes//sector speccification error") (#16R52 . "interleave specification error") (#16R53 . "invalid head address") (#16R54 . "invalid DMA burst count, 2190 only"))) (defun print-ip-error (error-number) (cond ((not (zerop error-number)) (format t "~%ip disk error #16r~16r: " error-number) (let ((error-message (assoc error-number ip-error-codes-alist))) (cond ((null error-message) (format t "not listed in manual")) (t (format t (cdr error-message)))))) (t (format t "~%no errors yet")))) (defconst interphase-timeout (* 3. 60.)) ;if no second arg, IOPB is in multbus memory. Otherwise, it can be in NUBUS memory. (DEFUN WAIT-FOR-IOPB-COMPLETION (&OPTIONAL (BREAK-ON-ERROR-P T) (FCTN 'READ-IOPB)) (prog2 (if share-trace (send standard-output ':tyo #/w)) (DO ((STATUS (READ-IOPB-STATUS FCTN) (READ-IOPB-STATUS FCTN)) (START-TIME (TIME))) ;initialize time (()) (COND ((OR (= STATUS 0) (= STATUS SMD-BUSY))) ;command in progress ((= STATUS SMD-OP-OK) (RETURN STATUS)) ((= STATUS SMD-ERROR) (COND ((NOT (NULL BREAK-ON-ERROR-P)) (PRINT-IP-ERROR (READ-IOPB-ERROR FCTN)) (ferror 'eagle-disk-error "disk error status ~o, type ~O" STATUS (READ-IOPB-ERROR FCTN)) (return status)) (T (RETURN STATUS)))) (T (FORMAT T "~%bad disk status read ~o: current iopb" STATUS) (PRINT-IOPB IOPB-BASE-ADDRESS FCTN))) (when ( (TIME-DIFFERENCE (TIME) START-TIME) interphase-timeout) (cerror "Do ~S and try again" "Disk timeout" '(initialize-disk-control)) (initialize-disk-control) (disk-go-command) (SETQ START-TIME (TIME))) ) (if share-trace (send *standard-output* :tyo #/W)))) (defun wait-for-iopb-completion-nubus (nubus-address &optional (break-on-error-p t) (fctn 'read-iopb-from-nubus)) (let ((iopb-base-address (* 4 nubus-address))) (wait-for-iopb-completion break-on-error-p fctn))) ;claims to work on 2181 revision levels 2.0 or higher, and 2190. doesnt seem to tho. (defun report-configuration () (set-iopb-pointer iopb-base-address) (build-iopb iopb-base-address smd-report-configuration-command 0 ;unit irrelevent, but initialize IOPB 0 ;head irrelevent, but initialize 0 ;cylinder irrelevent, but initialize 0 ;starting sector irrelevent 0 ;number of sectors irrelevent 0 ;dma-count irrelevent 0 ;buffer address, irrelevent ) (disk-go-command) (WAIT-FOR-IOPB-COMPLETION) (values (read-iopb 2) (read-iopb 3) (read-iopb 4) (read-iopb 5))) (DEFCONST UIB-BASE-ADDRESS 30) ;byte address (defun write-uib (address-within-uib data) (LET* ((ADR (+ UIB-BASE-ADDRESS ADDRESS-WITHIN-UIB)) (WD (multibus-read-32 ADR))) (SETQ WD (DPB DATA (BYTE 8 (* (LOGAND ADDRESS-WITHIN-UIB 3) 8)) WD)) (multibus-write-32 ADR WD))) (defun read-uib (address-within-uib) (LET ((WD (multibus-read-32 (+ UIB-BASE-ADDRESS ADDRESS-WITHIN-UIB)))) (LDB (BYTE 8 (* (LOGAND ADDRESS-WITHIN-UIB 3) 8)) WD))) (defun build-uib (uib-base-address heads-per-unit sectors-per-track bytes-per-sector gap1 gap2 interleave retry-count error-correction reseek bad-data head-increment dual-porting interrupt-on-change-status spiral-skew-factor group-size) (write-uib 0 heads-per-unit) (write-uib 1 sectors-per-track) (write-uib 2 (ldb 0010 bytes-per-sector)) ;LOW byte (opposite convention of iopb) (write-uib 3 (ldb 1010 bytes-per-sector)) ;HIGH byte (write-uib 4 gap1) (write-uib 5 gap2) (write-uib 6 interleave) (write-uib 7 retry-count) (write-uib 10 error-correction) (write-uib 11 reseek) (write-uib 12 bad-data) (write-uib 13 head-increment) (write-uib 14 dual-porting) (write-uib 15 interrupt-on-change-status) (write-uib 16 spiral-skew-factor) (write-uib 17 group-size) (write-uib 20 0) ;reserved (write-uib 21 0) ;reserved (write-uib 22 0)) ;reserved (defun read-uib-bytes-per-sector () (dpb (read-uib 3) 1010 (logand 377 (read-uib 2)))) (defun print-uib (&optional (uib-base-address uib-base-address)) (format t "~% heads per unit: ~o" (read-uib 0)) (format t "~% sectors per track: ~o" (read-uib 1)) (format t "~% bytes per sector: ~o" (read-uib-bytes-per-sector)) (format t "~% gap1: ~o" (read-uib 4)) (format t "~% gap2: ~o" (read-uib 5)) (format t "~% interleave: ~o" (read-uib 6)) (format t "~% retry count: ~o" (read-uib 7)) (format t "~% error correction: ~o" (read-uib 10)) (format t "~% reseek: ~o" (read-uib 11)) (format t "~% bad data: ~o" (read-uib 12)) (format t "~% head increment: ~o" (read-uib 13)) (format t "~% dual porting: ~o" (read-uib 14)) (format t "~% status interrupt: ~o" (read-uib 15)) (format t "~% spiral skew factor: ~o" (read-uib 16)) (format t "~% group size: ~o" (read-uib 17))) (DEFUN INITIALIZE-DISK-CONTROL (&OPTIONAL &KEY (UNIT DEFAULT-UNIT) (INTERLEAVE nil) ;nil means use default. (GROUP-SIZE 0) ;next three for 2190 only (GRP 0) (CE 0) (PRINTOUT T) (disk-type (send *proc* :disk-type)) ) ce grp group-size ; (if (= unit 0) ; (setq lambda-disk-type disk-type)) (cond ((null (send *proc* :disk-share-mode)) (funcall (get disk-type 'initialize-disk) unit interleave printout)) (t (insert-share-iopb) (setup-for-disk) (funcall (get disk-type 'setup-disk))))) (defun (eagle initialize-disk) (u i p) ;somewhat of a fake for now. (eagle-initialize-eagle u i 0 0 0 p)) ;;now converted for 1024 byte sectors. ;; Foo! with 1024 byte sectors, it wins on read with interleave of 3, but needs 4 on write! (defun eagle-initialize-eagle (unit interleave group-size grp ce ;these are relavent to 2190 only printout) (if (null interleave) (setq interleave 4)) ;default for eagle for now. (if printout (format t "~%initializing control for EAGLE on unit ~d" unit)) (SETUP-FOR-DISK) (setup-for-eagle) (cond (nil ; (access-path-lmi-serial-protocol *proc*) (format t "~%add something to serial protocol for (eagle-initialize)")) (t (build-uib uib-base-address heads-per-cylinder ;number of heads = 20 ;*** see also dcheck-disk-xfer if these change *** sectors-per-track ;sectors/track = 25. 1024. ;bytes/sector = 1024 28. ;gap1 = 28. (cond ((= group-size 0) 28.) ;gap2 = 28. 2181 (t 31.)) ; 2190 (dpb grp 0701 (dpb ce 0601 interleave)) ;interleave 3 ;retry count = 3 1 ;error correction attempt allowed = 1 1 ;number of reseek attempts = 1 0 ;bad data allowed through = 0 1 ;head-increment rather than seek = 1 0 ;no dual-porting = 0 0 ;don't allow interrupt-on-change-status = 0 12. ;spiral-skew-factor group-size) (if printout (print-uib)) (build-iopb iopb-base-address smd-initialize-command unit 0 ;head 0 ;cylinder 0 ;starting address 0 ;number of sectors 2 ;dma count (list uib-base-address)) ;uib address. Really at 30, do not offset! (if printout (print-iopb)) (set-iopb-pointer iopb-base-address) (disk-go-command) (WAIT-FOR-IOPB-COMPLETION)))) (defprop t302 eagle-initialize-t302 initialize-disk) (defun eagle-initialize-t302 (unit interleave printout) (if (null interleave) (setq interleave 3)) ;default for t302. (SETUP-FOR-DISK) (if printout (format t "~%initializing control for T302 on unit ~d" unit)) (setup-for-t302) (cond ((access-path-lmi-serial-protocol *proc*) (format t "~%add something to serial protocol for (eagle-initialize)")) (t (build-uib uib-base-address heads-per-cylinder ;number of heads ;*** see also dcheck-disk-xfer if these change *** sectors-per-track ;sectors/track 1024. ;bytes/sector = 1024 20. ;gap1 = 20. 22. ;gap2 = 22. interleave ;interleave 3 ;retry count = 3 1 ;error correction attempt allowed = 1 1 ;number of reseek attempts = 1 0 ;bad data allowed through = 0 1 ;head-increment rather than seek = 1 0 ;no dual-porting = 0 0 ;don't allow interrupt-on-change-status = 0 12. ;spiral-skew-factor 0 ;group size (2190) ) (if printout (print-uib)) (build-iopb iopb-base-address smd-initialize-command unit 0 ;head 0 ;cylinder 0 ;starting address 0 ;number of sectors 2 ;dma count uib-base-address) ;uib address (if printout (print-iopb)) (set-iopb-pointer iopb-base-address) (disk-go-command) (WAIT-FOR-IOPB-COMPLETION)))) (defun INITIALIZE-GENERIC-DISK (unit interleave printout) (if (null interleave) (setq interleave (GETDISKP ':INTERLEAVE))) (SETUP-FOR-DISK) (if printout (format t "~%initializing control for ~A on unit ~d" (generic-disk-name) unit)) (FUNCALL (GET (generic-disk-type) 'SETUP-DISK)) (cond ((access-path-lmi-serial-protocol *proc*) (format t "~%add something to serial protocol for (eagle-initialize)")) (t (build-uib uib-base-address heads-per-cylinder ;number of heads ;*** see also dcheck-disk-xfer if these change *** sectors-per-track ;sectors/track (getdiskp ':bytes-per-sector) (getdiskp ':gap1) (getdiskp ':gap2) interleave (getdiskp ':retry-count 3) (getdiskp ':error-correction-attempt 1) (getdiskp ':number-of-reseek-attempts 1) (getdiskp ':bad-data-allowed-through 0) (getdiskp ':head-increment-rather-than-seek 1) (getdiskp ':dual-porting 0) (getdiskp ':dont-allow-interrupt-on-change-status 0) (getdiskp ':spiral-skew-factor) (getdiskp ':group-size 0) ) (if printout (print-uib)) (build-iopb iopb-base-address smd-initialize-command unit 0 ;head 0 ;cylinder 0 ;starting address 0 ;number of sectors 2 ;dma count uib-base-address) ;uib address (if printout (print-iopb)) (set-iopb-pointer iopb-base-address) (disk-go-command) (WAIT-FOR-IOPB-COMPLETION)))) (DEFUN LAM-DISK-XFER-VIA-NUBUS (FCN DISK-BLOCK-NUM CORE-PAGE-NUM N-BLOCKS &optional (dma-count 2)) (cond ((and (null sectors-per-track) (eq (send *proc* :disk-type) 'unknown)) (really-setup-for-unknown))) (PROG (CYLINDER HEAD SECTOR ERRCNT DBN FINAL-ADDRESS FINAL-SECTOR FINAL-HEAD FINAL-CYLINDER) (LET ((SECTORS-PER-CYLINDER (* sectors-per-track heads-per-cylinder)) ;BLOCKS-PER-CYLINDER ;(SECTORS-PER-TRACK BLOCKS-PER-TRACK) ) (SETQ DBN DISK-BLOCK-NUM) ; (COND ((NOT LAM-DISK-TYPE)(LAM-DISK-INIT))) (SETQ ERRCNT LAM-DISK-RETRY-COUNT) (COND ((NUMBERP DBN) (SETQ CYLINDER (// DBN SECTORS-PER-CYLINDER)) (SETQ SECTOR (\ DBN SECTORS-PER-CYLINDER)) (SETQ HEAD (// SECTOR SECTORS-PER-TRACK) SECTOR (\ SECTOR SECTORS-PER-TRACK)) (SETQ FINAL-ADDRESS (+ DBN (1- N-BLOCKS)) FINAL-CYLINDER (// FINAL-ADDRESS SECTORS-PER-CYLINDER) FINAL-SECTOR (\ FINAL-ADDRESS SECTORS-PER-CYLINDER) FINAL-HEAD (// FINAL-SECTOR SECTORS-PER-TRACK) FINAL-SECTOR (\ FINAL-SECTOR SECTORS-PER-TRACK))) (T (SETQ CYLINDER (CAR DBN) HEAD (CADR DBN) SECTOR (CADDR DBN)))) (setq cylinder (lam-offset-cylinder cylinder)) (WRITE-MULTIBUS-MAPPING-REGISTER lam-multibus-mapping-register-base (+ 1_23. (CADR-PAGE-TO-NUBUS-PAGE 1))) ;sys-communication-area, page 1 (SET-IOPB-POINTER (+ (ASH lam-multibus-mapping-register-base 10.) (* 250 4)) nil) ;byte adr within page. (DOTIMES (C N-BLOCKS) (WRITE-MULTIBUS-MAPPING-REGISTER (+ lam-multibus-mapping-register-base lam-multibus-mapping-register-data-offset c) (+ 1_23. (CADR-PAGE-TO-NUBUS-PAGE(+ C CORE-PAGE-NUM))))) (BUILD-IOPB-IN-NUBUS-MEMORY 650 FCN DEFAULT-UNIT HEAD CYLINDER SECTOR N-BLOCKS dma-count (ASH (+ lam-multibus-mapping-register-base lam-multibus-mapping-register-data-offset) 10.)) (DISK-GO-COMMAND) (WAIT-FOR-IOPB-COMPLETION-NUBUS 650) (RETURN T)))) ;;; routines to support shared disk -pace 3/21/84 (defun multibus-address-to-8086-ptr (adr) (dpb (ldb (byte 16. 4) adr) (byte 16. 16.) (ldb (byte 4. 0) adr))) (defun 8086-ptr-to-multibus-address (ptr) (+ (ash (ldb (byte 16. 16.) ptr) 4) (ldb (byte 16. 0) ptr) #xff000000)) ; first there is the share-iopb-chain, located at a well known place ; in multibus memory. The head of the chain is a structure that looks like: ; ; ptr-to-first-share-iopb - 4 byte 8086 address ; lock-byte - 1 byte - set to 0 if free, 1 if someone is looking at the chain ; debug-byte - 1 byte set to the debug level given to the share starter 8086 program (defconst sharestruct-ptr #xff000080) (defconst sharestruct-lock #xff000084) (defconst sharestruct-debug-level #xff000085) (defconst sharestruct-share-lock 0) (defconst sharestruct-max-iopbs-offset 4) (defconst sharestruct-current-iopb-offset 8) (defconst sharestruct-valid-table-offset 12.) (defconst share-iopb-runme-offset 0) (defconst share-iopb-slot-offset 4) (defconst share-iopb-type-offset 8) (defconst share-iopb-iopb-offset 12.) (defconst share-iopb-interrupt-offset 16.) (defun sharestruct-valid-p () (not (zerop (ldb (byte 20. 0) (read-8086-multibus-address sharestruct-ptr))))) ; these are word addresses in mem-slot (defconst lambda-share-iopb-structure 520) ; see qcom (defconst debug-program-share-iopb-structure 540) (defvar share-lock-prevent-accidental-recursion nil) (defconst enable-locking t) (defun share-lock () (cond ((or (null enable-locking) (typep *proc* 'local-access-path))) ;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) (ferror nil "timeout waiting for share-lock")) (do () ((zerop (send *proc* :bus-read-byte sharestruct-lock))))) (send *proc* :bus-write-byte sharestruct-lock 1)) (t (ferror nil "share-lock called while cadr apparently already had lock")))) (defun share-unlock () (cond ((or (null enable-locking) (typep *proc* 'local-access-path))) (t (setq share-lock-prevent-accidental-recursion nil) (send *proc* :bus-write-byte sharestruct-lock 0)))) (defun read-8086-multibus-address (nubus-pointer-location) (let ((multibus-address (8086-ptr-to-multibus-address (cond ((zerop (ldb 0002 nubus-pointer-location)) (send *proc* :bus-quad-slot-read-unsafe (ldb (byte 8 24.) nubus-pointer-location) (ldb (byte 24. 0) nubus-pointer-location))) (t (logior (send *proc* :bus-read-byte-unsafe nubus-pointer-location) (ash (send *proc* :bus-read-byte-unsafe (+ nubus-pointer-location 1)) 8) (ash (send *proc* :bus-read-byte-unsafe (+ nubus-pointer-location 2)) 16.) (ash (send *proc* :bus-read-byte-unsafe (+ nubus-pointer-location 3)) 24.))))))) (values (map-multibus-address multibus-address) multibus-address))) (defun map-multibus-address (nubus-address) "return nubus-address, unless it points to the multibus, and is mapped to the nubus. in that case, follow the mapping, and return that address" (cond ((not (= (ldb (byte 8 24.) nubus-address) #xff)) nubus-address) (t (let ((map-to (read-multibus-mapping-register (ldb 1212 nubus-address)))) (cond ((ldb-test 2701 map-to) ; check valid bit (dpb (ldb 0026 map-to) (byte 22. 10.) (ldb (byte 10. 0) nubus-address))) (t nubus-address)))))) (defun print-share-iopbs (&optional print-iopbs) (format t "~&sharestruct-debug-level = ~d." (send *proc* :bus-read-byte sharestruct-debug-level)) (format t "~&sharestruct-lock = ~o" (send *proc* :bus-read-byte sharestruct-lock)) (share-lock) (unwind-protect (let ((sharestruct (read-8086-multibus-address sharestruct-ptr))) (format t "~&sharestruct = ~16r" sharestruct) (cond ((zerop (ldb (byte 20. 0) sharestruct)) (ferror nil "~&sharestruct pointer not set up yet"))) (let ((maxiopbs (send *proc* :bus-read-byte (+ sharestruct sharestruct-max-iopbs-offset ))) (currentiopb (send *proc* :bus-read-byte (+ sharestruct sharestruct-current-iopb-offset)))) (format t "~&maxiopbs = ~d" maxiopbs) (format t "~¤tiopb = ~d" currentiopb) (dotimes (n maxiopbs) (let ((valid (send *proc* :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: (~16r) valid = #x~16r siopb = #x~16r" 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~16r)" adr adr) (format t "~&~8trunme = ~o" (send *proc* :bus-read-byte-unsafe (+ adr share-iopb-runme-offset))) (format t "~&~8tslot = ~o (#x~:*~16r)" (send *proc* :bus-read-byte-unsafe (+ adr share-iopb-slot-offset))) (format t "~&~8ttype = ~o" (send *proc* :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 ~:* ~16r" 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 ~16r)" inter-multi-loc (map-multibus-address inter-multi-loc)))) (defconst cadr-share-slot (cond ((= si:processor-type-code si:cadr-type-code) 377) ((= si:processor-type-code si:lambda-type-code) (cond ((not (boundp 'si:*my-op*)) 376) (t (- 375 (si:op-proc-number si:*my-op*))))))) (defconst cadr-share-type 377) (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 (ldb (byte 20. 0) sharestruct)) (ferror nil "~&sharestruct pointer not set up yet"))) (let ((maxiopbs (send *proc* :bus-read-byte (+ sharestruct sharestruct-max-iopbs-offset)))) (dotimes (n maxiopbs) (let ((valid (send *proc* :bus-read-byte (+ 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 (send *proc* :bus-read-byte-unsafe (+ siopb share-iopb-slot-offset))) (this-type (send *proc* :bus-read-byte-unsafe (+ siopb share-iopb-type-offset)))) (cond ((and (or (= this-slot slot) (= this-slot (logxor #xf0 slot))) (= this-type type)) (send *proc* :bus-write-byte (+ sharestruct sharestruct-valid-table-offset (* n 4)) 0))) (when (not (memq (ldb (byte 4 4) this-slot) '(0 1 #xe #xf))) (print-share-iopb siopb) (if (if ask-p (y-or-n-p "Flush this IOPB ") (format t "Flushing this IOPB ") t) (send *proc* :bus-write-byte (+ 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 (ldb (byte 20. 0) sharestruct)) (ferror nil "sharestruct not set up yet"))) (let ((maxiopbs (send *proc* :bus-read-byte (+ sharestruct sharestruct-max-iopbs-offset)))) (cond ((>= slot-number maxiopbs) (ferror nil "there are only ~d slots" maxiopbs))) (send *proc* :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 (send *proc* :memory-configuration-list))) 10.) ;;(dpb (SEND *PROC* :MEM-SLOT) (byte 4 24.) #xf0000000) (* debug-program-share-iopb-structure 4)))) (format t "~%prime-memory-adr for iopb=#x~16r" prime-memory-adr) (send *proc* :bus-write (+ prime-memory-adr share-iopb-runme-offset) 0) (send *proc* :bus-write (+ prime-memory-adr share-iopb-slot-offset) cadr-share-slot) (send *proc* :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 (write-multibus-mapping-register lam-multibus-mapping-register-base (+ 1_23. (cadr-page-to-nubus-page 1))) (send *proc* :bus-write (+ prime-memory-adr share-iopb-iopb-offset) (multibus-address-to-8086-ptr (+ (ash lam-multibus-mapping-register-base 10.) (* 250 4)))) ;;no interrupts (send *proc* :bus-write (+ prime-memory-adr share-iopb-interrupt-offset) 0) (share-lock) (unwind-protect (let ((sharestruct (read-8086-multibus-address sharestruct-ptr))) (cond ((zerop (ldb (byte 20. 0) sharestruct)) (ferror nil "~&sharestruct pointer not set up yet"))) (let ((maxiopbs (send *proc* :bus-read-byte (+ sharestruct sharestruct-max-iopbs-offset)))) (dotimes (n maxiopbs (ferror nil "out of iopb slots")) (cond ((zerop (send *proc* :bus-read-byte (+ sharestruct sharestruct-valid-table-offset (* 4 n)))) (send *proc* :bus-write (+ sharestruct sharestruct-valid-table-offset (* 4 maxiopbs) (* 4 n)) (multibus-address-to-8086-ptr (+ (ash lam-multibus-mapping-register-base 10.) (* 140 4)))) (send *proc* :bus-write-byte (+ sharestruct sharestruct-valid-table-offset (* 4 n)) 1) (return nil)))))) (share-unlock)))) (defconst multibus-interrupt-1 #xff01c1e4) (defconst multibus-interrupt-7 #xff01c1fc) (defconst share-trace nil) (defun share-go () (if share-trace (send standard-output ':tyo #/g)) (let ((prime-memory-adr (+ (ash (cadr (car (send *proc* :memory-configuration-list))) 10.) ;(dpb (SEND *PROC* :MEM-SLOT) (byte 4 24.) #xf0000000) (* debug-program-share-iopb-structure 4)))) (send *proc* :bus-write-byte (+ prime-memory-adr share-iopb-runme-offset) 1) (send *proc* :bus-write-byte 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 = ~16r" sharestruct) (cond ((zerop (ldb (byte 20. 0) sharestruct)) (ferror nil "~&sharestruct pointer not set up yet"))) (let ((maxiopbs (send *proc* :bus-read-byte (+ sharestruct sharestruct-max-iopbs-offset ))) (currentiopb (send *proc* :bus-read-byte (+ sharestruct sharestruct-current-iopb-offset)))) (format t "~&maxiopbs = ~d" maxiopbs) (format t "~¤tiopb = ~d" currentiopb) (dotimes (n maxiopbs) (let ((valid (send *proc* :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: (~16r) valid = #x~16r siopb = #x~16r" 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?")) (send *proc* :bus-write-byte-unsafe (+ siopb share-iopb-runme-offset) 1))))))) (share-unlock)))