source: trunk/lisp/lmcons/dcheck.lisp @ 271

Last change on this file since 271 was 271, checked in by rjs, 7 years ago

Update from System 78.

File size: 41.0 KB
Line 
1;;; -*- Mode:Lisp; Package:CADR; Base:8 -*-
2
3;;; DCHECK - for checking out newly-constructed disk controls
4;;; Goes in CADR package
5
6(DECLARE (COND ((STATUS FEATURE LISPM))   ;DO NOTHING ON LISP MACHINE.
7               ((NULL (MEMQ 'NEWIO (STATUS FEATURES)))
8                (BREAK 'YOU-HAVE-TO-COMPILE-THIS-WITH-QCOMPL T))
9               ((NULL (GET 'IF-FOR-MACLISP 'MACRO))
10                (LOAD '(MACROS > DSK LISPM2))  ;Just #M and #Q really
11                (MACROS T)))) ;SEND OVER THE REST OF THE MACROS IN THIS FILE
12
13(DECLARE (SPECIAL BYPASS-SEEKS))
14(SETQ BYPASS-SEEKS NIL) ;NON-NIL INHIBITS SEEKING IN DCHECK
15
16(DEFVAR MARKSMAN-P NIL) ;You must set this to T if you are testing a marksman
17
18(declare (special local-disk-p))  ;Local disk at normal address -4
19(setq local-disk-p nil)
20
21(DECLARE (SPECIAL SPY-ACCESS-PATH CC-SUSPECT-BIT-LIST CC-DIAG-TRACE
22                  DCHECK-AND DCHECK-IOR DCHECK-ADR-AND DCHECK-ADR-IOR
23                  DC-STS-ADR DC-MA-ADR DC-DA-ADR DC-ECC-ADR DC-CMD-ADR DC-CLP-ADR DC-START-ADR
24                  DC-READ DC-WRITE DC-SEEK DC-RECAL DC-FAULT-CLEAR DC-READ-ALL DC-WRITE-ALL
25                  DC-READ-COMPARE DC-AT-EASE DC-OFFSET-CLEAR DC-STOP
26                  DC-SOME-ERROR-BITS DC-ALL-ERROR-BITS CCW-LOC NXM-LOC1 NXM-LOC2 NXM-LOC3))
27
28(SETQ DC-STS-ADR 17377774
29      DC-MA-ADR 17377775
30      DC-DA-ADR 17377776
31      DC-ECC-ADR 17377777
32      DC-CMD-ADR 17377774
33      DC-CLP-ADR 17377775
34      DC-START-ADR 17377777)
35
36(SETQ DC-READ 0 DC-READ-COMPARE 10 DC-WRITE 11 DC-READ-ALL 2 DC-WRITE-ALL 13
37      DC-SEEK 4 DC-AT-EASE 5 DC-RECAL 10001005 DC-FAULT-CLEAR 10000405 DC-OFFSET-CLEAR 6
38      DC-STOP 16)
39
40(SETQ DC-SOME-ERROR-BITS 06077560  ;MUL-SEL, NO-SEL, FLT, OFF-CYL, OFF-LINE, SEEK-ERR, TIMEOUT,
41                                   ;START-BLOCK, TRANSFER-ABORTED, OVERRUN, PAR, NXM
42      DC-ALL-ERROR-BITS ;47777560   ;ALSO ECC-SOFT, ECC-HARD, ECC-HDR, HCE, IPE
43                        (+ (LSH 1 23.) 7777560) ;AVOID MAKING BIGNUM
44      CCW-LOC 777
45      NXM-LOC1 16777777          ;THESE 3 ATTEMPT TO GET 1 AND 0 IN ALL BITS
46      NXM-LOC2 15000000          ;ASSUMING MACHINE HAS LESS THAN 1792K CORE
47      NXM-LOC3 07000000)
48
49(PROGN 'COMPILE  ;Damned splicing macros don't work at top level
50#M (PROGN 'COMPILE
51(DECLARE (FIXNUM (PHYS-MEM-READ FIXNUM) (DC-READ-MA))
52         (NOTYPE (PHYS-MEM-WRITE FIXNUM FIXNUM)
53                 (DCHECK-COMPARE FIXNUM FIXNUM) (DCHECK-PM NOTYPE FIXNUM)))
54
55(DECLARE (*EXPR PHYS-MEM-READ PHYS-MEM-WRITE
56                CC-FINGER-SUSPECT-BIT CC-PRINT-SET-BITS CC-PRINT-BIT-LIST))
57
58(DECLARE (FIXNUM I J K M N BITNO MASK ADR VAL))
59
60(DEFUN LOGAND MACRO (X) `(BOOLE 1 . ,(CDR X)))
61
62(DEFUN LOGIOR MACRO (X) `(BOOLE 7 . ,(CDR X)))
63
64(DEFUN LOGXOR MACRO (X) `(BOOLE 6 . ,(CDR X)))
65
66(DEFUN LDB-TEST MACRO (X)
67  (LET ((PP (LSH (CADR X) -6))
68        (SS (LOGAND 77 (CADR X)))
69        (W (CADDR X)))
70    (LIST 'NOT (LIST 'ZEROP (LIST 'LOGAND (LSH (1- (LSH 1 SS)) PP) W)))))
71
72(DEFUN PHYS-MEM-READ-24 MACRO (X)
73  (RPLACA X 'PHYS-MEM-READ))
74
75);#M
76
77#Q
78(DEFUN PHYS-MEM-READ-24 MACRO (X)
79  `(LET ((VAL (PHYS-MEM-READ . , (CDR X))))
80     (LOGIOR (LSH (LDB 2701 VAL) 27) (LDB 27 VAL)))) ;Ensure fixnum
81);PROGN 'COMPILE
82
83(defun use-local-disk ()
84  (setq local-disk-p t
85        DC-STS-ADR 377770
86        DC-MA-ADR 377771
87        DC-DA-ADR 377772
88        DC-ECC-ADR 377773
89        DC-CMD-ADR 377770
90        DC-CLP-ADR 377771
91        DC-START-ADR 377773)
92  (fset'phys-mem-read 'xbus-read)
93  (fset'phys-mem-write 'xbus-write))
94
95(defun xbus-read (loc)
96  (setq loc (+ loc (lsh 77 18.)))
97  (dpb (%p-ldb 2020 loc) 2020 (%p-ldb 0020 loc)))
98
99(defun xbus-write (loc val)
100  (%p-store-tag-and-pointer (+ loc (lsh 77 18.))
101                            (ldb 3010 val)
102                            (%24-bit-plus (lsh (ldb 2701 val) 27)
103                                          (ldb 0027 val))))
104
105
106;;; Basic disk manipulation
107
108(DEFUN DC-READ-MA ()  ;High bits of this register are garbage, only 22 bits are really MA
109  (LOGLDB 0026 (PHYS-MEM-READ DC-MA-ADR)))
110
111(DEFUN DC-PRINT-STATUS ()
112  (DC-PRINT-STATUS1 (PHYS-MEM-READ DC-STS-ADR)))
113
114(DEFUN DC-PRINT-STATUS1 (STATUS)
115     (TERPRI)
116     (CC-PRINT-SET-BITS STATUS '( IDLE ANY-ATTN SEL-UNIT-ATTN INTR MULTIPLE-SELECT NO-SELECT
117                                  SEL-UNIT-FAULT SEL-UNIT-READ-ONLY SEL-UNIT-OFF-CYLINDER
118                                  SEL-UNIT-OFF-LINE SEL-UNIT-SEEK-ERROR TIMEOUT-ERROR
119                                  START-BLOCK-ERROR TRANSFER-ABORTED OVERRUN
120                                  ECC-SOFT ECC-HARD ECC-HEADER HEADER-COMPARE-ERROR
121                                  MEM-PARITY-ERROR NXM-ERROR CCW-CYCLE READ-COMPARE-DIFFERENCE
122                                  INTERNAL-PARITY-ERROR ))
123     
124     #M (PROGN (PRINC '| SEL-UNIT-BLOCK-CTR=|) (PRIN1 (LSH STATUS -24.))))
125
126;;; Seek, print status if error
127(DEFUN DC-SEEK (CYL &OPTIONAL (UNIT 0))
128  (PHYS-MEM-WRITE DC-DA-ADR (ASH UNIT 28.))
129  (PHYS-MEM-WRITE DC-CMD-ADR DC-AT-EASE)
130  (PHYS-MEM-WRITE DC-START-ADR 0)
131  (DO () ((LDB-TEST 0001 (PHYS-MEM-READ DC-STS-ADR)))) ;Await Idle
132  (PHYS-MEM-WRITE DC-DA-ADR (LOGDPB CYL 2014 (ASH UNIT 28.)))
133  (PHYS-MEM-WRITE DC-CMD-ADR (LOGDPB CYL 3010 (LOGDPB 100 2010 DC-SEEK)))
134  (PHYS-MEM-WRITE DC-START-ADR 0)
135  (DO () ((LDB-TEST 0001 (PHYS-MEM-READ DC-STS-ADR)))) ;Await Idle
136  (DO () ((LDB-TEST 0201 (PHYS-MEM-READ DC-STS-ADR))) ;Await attention
137    #M (SLEEP 0.03)
138    #Q (PROCESS-ALLOW-SCHEDULE)
139    )
140  (DC-CHECK-STATUS DC-SOME-ERROR-BITS))
141
142;;; Perform a read or write, check specified status bits.
143(DEFUN DC-EXEC (CMD CYL HEAD BLOCK CLP CCW ERR-BITS &OPTIONAL (UNIT 0))
144  (PHYS-MEM-WRITE DC-DA-ADR (ASH UNIT 28.))
145  (PHYS-MEM-WRITE DC-CMD-ADR DC-AT-EASE)
146  (PHYS-MEM-WRITE DC-START-ADR 0)
147  (DO () ((LDB-TEST 0001 (PHYS-MEM-READ DC-STS-ADR)))) ;Await Idle
148  (PHYS-MEM-WRITE DC-DA-ADR (LOGDPB UNIT 3404 (LOGDPB CYL 2014 (+ (LSH HEAD 8) BLOCK))))
149  (PHYS-MEM-WRITE DC-CLP-ADR CLP)
150  (AND CCW (PHYS-MEM-WRITE CLP CCW))
151  (PHYS-MEM-WRITE DC-CMD-ADR CMD)
152  (PHYS-MEM-WRITE DC-START-ADR 0)
153  (DO () ((LDB-TEST 0001 (PHYS-MEM-READ DC-STS-ADR))) ;Await Idle
154    #M (SLEEP 0.03)
155    #Q (KBD-CHAR-AVAILABLE)
156    )
157  (DC-CHECK-STATUS ERR-BITS))
158
159;;; Very simplified version used for reading back status.  Don't want to bash
160;;; disk address register.
161(DEFUN DC-EXEC-1 (CMD)
162  (DO () ((LDB-TEST 0001 (PHYS-MEM-READ DC-STS-ADR)))) ;Await Idle
163  (PHYS-MEM-WRITE DC-CMD-ADR CMD)
164  (PHYS-MEM-WRITE DC-START-ADR 0)
165  (DO () ((LDB-TEST 0001 (PHYS-MEM-READ DC-STS-ADR))) ;Await Idle
166    #M (SLEEP 0.03)
167    #Q (KBD-CHAR-AVAILABLE)
168    ))
169
170;;; Barf if any of specified bits on in status
171(DEFUN DC-CHECK-STATUS (MASK)
172  (LET ((VAL (PHYS-MEM-READ-24 DC-STS-ADR)))
173    (COND ((NOT (ZEROP (LOGAND MASK VAL)))
174           (DC-PRINT-STATUS1 VAL)
175           (let ((ecc (phys-mem-read dc-ecc-adr))
176                 (da  (phys-mem-read dc-da-adr))
177                 (ma  (phys-mem-read dc-ma-adr)))
178             (format t "CYL ~O, HEAD ~O, SEC ~O, MA ~O, ECC pat ~O, ECC pos ~O"
179                     (ldb 2014 da) (ldb 1010 da) (ldb 0010 da)
180                     (dpb (ldb 2010 ma) 2010 (ldb 0020 ma))
181                     (ldb 2020 ecc) (ldb 0020 ecc)))
182           T))))
183
184;;; This function provides a scope loop for debugging problems starting up
185;;; the microcode that would otherwise lead to hangs.
186(DEFUN DC-RAPID-START ()
187  (DO () ((KBD-TYI-NO-HANG))
188    (PHYS-MEM-WRITE DC-CMD-ADR DC-AT-EASE)      ;Do the command that loses (at ease
189    (PHYS-MEM-WRITE DC-START-ADR 0)             ; is the most null command)
190    (DOTIMES (I 100) NIL)
191    (PHYS-MEM-WRITE DC-CMD-ADR DC-STOP)         ;Stop the disk control forcibly
192    (PHYS-MEM-WRITE DC-CMD-ADR DC-AT-EASE)))    ;Cease to stop
193
194;;; Simpler version of DC-EXEC, for scoping
195(DEFUN DC-EXEC-2 (CMD CYL HEAD BLOCK CLP CCW ERR-BITS)
196  (PHYS-MEM-WRITE DC-DA-ADR (LOGDPB CYL 2014 (+ (LSH HEAD 8) BLOCK)))
197  (PHYS-MEM-WRITE DC-CLP-ADR CLP)
198  (AND CCW (PHYS-MEM-WRITE CLP CCW))
199  (PHYS-MEM-WRITE DC-CMD-ADR CMD)
200  (PHYS-MEM-WRITE DC-START-ADR 0)
201  (DO () ((LDB-TEST 0001 (PHYS-MEM-READ DC-STS-ADR))) ;Await Idle
202    #M (SLEEP 0.03)
203    #Q (KBD-CHAR-AVAILABLE)
204    )
205  (DC-CHECK-STATUS ERR-BITS))
206
207;;; Test function
208
209(DEFUN DCHECK (&OPTIONAL (UNIT 0) &AUX CONTROLLER-TYPE)
210  (SETQ CONTROLLER-TYPE (LDB (BITS 2 22.) (PHYS-MEM-READ DC-MA-ADR)))
211  (FORMAT T
212      "~&CONTROLLER TYPE IS ~D~0G (~[Trident~;Marksman~;unused?~;Unmodified Trident~])~%"
213      CONTROLLER-TYPE)
214  ;Don't do this, the hardware isn't necessarily right.  This IS a diagnostic, after all.
215  ;(SETQ FOO-P (= CONTROLLER-TYPE 1))
216  ;(FORMAT T "~&Operating as if ~:[Trident~;Marksman~]~%" MARKSMAN-P)
217  ;; Part 1 - verify bus response to reading and writing disk-address register
218  (PHYS-MEM-WRITE DC-DA-ADR 1777777777) ;28 bits
219  (COND ((ZEROP (PHYS-MEM-READ DC-DA-ADR))
220         (DCHECK-ERR-LOOP '|No response on Unibus or Xbus, or failed to write or read DA|
221                          DC-DA-ADR 1777777777 1777777777)))
222  ;; Part 2 - write 0 in DA, check for bits stuck at 1
223  (PHYS-MEM-WRITE DC-DA-ADR 0)
224  (DO ((VAL (PHYS-MEM-READ DC-DA-ADR))
225       (BITNO 0 (1+ BITNO))
226       #M (MASK 1 (LSH MASK 1))
227       (CC-SUSPECT-BIT-LIST NIL))
228      ((= BITNO 28.)
229       (COND ((NOT (NULL CC-SUSPECT-BIT-LIST))
230              (CC-PRINT-BIT-LIST '|Bits in DA register stuck at 1, may be/
231  broken wire in XBI or XBO data paths: |
232                                 CC-SUSPECT-BIT-LIST)
233              (DCHECK-ERR-LOOP '|Some bits in DA register won't clear|
234                               DC-DA-ADR 0 0))))
235    (AND #M (NOT (ZEROP (LOGAND MASK VAL)))
236         #Q (LDB-TEST (1+ (LSH BITNO 6)) VAL)
237         (CC-FINGER-SUSPECT-BIT BITNO)))
238  ;; Part 3 - write floating 1's in DA, check for bits stuck at 0 or spuriously 1
239  (DO ((BITNO 0 (1+ BITNO))
240       (MASK 1 (+ MASK MASK)) ;May be bignum on Lisp machine
241       #Q (PPSS 0001 (+ PPSS 100))
242       (VAL)
243       (CC-SUSPECT-BIT-LIST NIL)
244       (STUCK-0 NIL)
245       (SPURIOUS-1 NIL))
246      ((= BITNO 28.)
247       (CC-PRINT-BIT-LIST '|Bits in DA register stuck at 0: | STUCK-0)
248       (CC-PRINT-BIT-LIST '|Bits in DA register 1 when they shouldn't be: | SPURIOUS-1)
249       (AND STUCK-0
250            (DCHECK-ERR-LOOP '|Testing first stuck-0 bit in DA register:|
251                             DC-DA-ADR 0 (LOGDPB 1 (1+ (LSH (CAR STUCK-0) 6)) 0)))
252       (AND SPURIOUS-1
253            (DCHECK-ERR-LOOP '|Testing first spurious-1 bit in DA register:|
254                            DC-DA-ADR 0 (LOGDPB 0 (1+ (LSH (CAR SPURIOUS-1) 6)) 1777777777))))
255    (PHYS-MEM-WRITE DC-DA-ADR MASK)
256    (SETQ VAL (PHYS-MEM-READ DC-DA-ADR))
257    (AND #M (ZEROP (LOGAND MASK VAL))
258         #Q (NOT (LDB-TEST PPSS VAL))
259         (SETQ STUCK-0 (CONS BITNO STUCK-0)))
260    (DO I 0 (1+ I) (= I 28.)
261      (AND (NOT (= I BITNO))
262           #M (NOT (ZEROP (LOGAND (LSH 1 I) VAL)))
263           #Q (LDB-TEST (1+ (LSH I 6)) VAL)
264           (SETQ SPURIOUS-1 (CONS I SPURIOUS-1)))))
265  ;; Part 3.5 - check that the block counter is counting.  This checks
266  ;; that the disk is rotating and that the index/sector pulse logic works.
267  (PHYS-MEM-WRITE DC-DA-ADR (ASH UNIT 28.))
268  #Q (DCHECK-BLOCK-COUNTER)
269  ;; Part 3.6 - recalibrate. 
270  (FORMAT T "~&Recalibrate...")
271  (DC-RECALIBRATE UNIT)
272  ;; Part 4 - Test disk bus bits and basic command logic by seeking
273  (COND ((NOT BYPASS-SEEKS)
274         (DCHECK-SEEK 814. UNIT)
275         (DO I 512. (LSH I -1) (ZEROP I)
276           (DCHECK-SEEK I UNIT))))
277  (and local-disk-p (break the-rest-of-this-aint-gonna-work))
278  ;; Part 5 - Check address logic by reading with a CLP that points at NXM
279  ;;          and then a CCW that points at NXM, check error status and MA.
280  ;;   Note that if the read fails to happen, e.g. due to header-compare-error, the
281  ;;   MA is naturally going to be wrong also since no memory cycles at all will happen.
282  (LET ((MASK   ;Bits which are suspect (this stuff is only 22 bits, fits in fixnum)
283         (LOGIOR (DCHECK-CLP-ADR NXM-LOC1 UNIT)
284                 (DCHECK-CLP-ADR NXM-LOC2 UNIT)
285                 (DCHECK-CLP-ADR NXM-LOC3 UNIT)
286                 (DCHECK-CCW-ADR NXM-LOC3 UNIT)
287                 (DCHECK-CCW-ADR NXM-LOC2 UNIT)
288                 (DCHECK-CCW-ADR NXM-LOC1 UNIT)
289                 )))
290    (COND ((NOT (ZEROP MASK))
291           (DCHECK-ERR-LOOP   ;Not the ultimate winning test loop, but maybe OK for now
292              '|Writing CLP, reading MA (should be 16777777), frobbing bits that failed|
293              DC-CLP-ADR 0 MASK))))
294  ;; Part 6 - Write and read block 1 of the disk.  Use a floating 1's and 0's
295  ;;          pattern, and then an address pattern, and check for Xbus data path
296  ;;          and addressing failures.
297  ;; This doesn't check high-order address bits
298  (DO I 0 (1+ I) (= I 40)       ;Loc 0-37 get floating 1's
299    (PHYS-MEM-WRITE I (#M LSH #Q ASH 1 I)))
300  (DO I 0 (1+ I) (= I 40)       ;Loc 40-77 get floating 0's
301    (PHYS-MEM-WRITE (+ 40 I) (- (#M LSH #Q ASH 1 32.) (#M LSH #Q ASH 1 I))))
302  (DO I 100 (1+ I) (= I 400)    ;Loc 100-377 get address pattern
303    (PHYS-MEM-WRITE I (+ (LSH (LOGXOR 377 I) 8) I)))
304  (PRINT 'WRITE)
305  (DC-EXEC DC-WRITE 0 0 1 CCW-LOC 0 DC-ALL-ERROR-BITS UNIT)
306  (LET ((MA (DC-READ-MA)))
307    #M (DECLARE (FIXNUM MA))
308    (COND ((NOT (= MA 377))
309           (TERPRI) (PRINC '|MA wrong on write of pattern, correct=377, actual=|)
310           (PRIN1 MA))))
311  (DO I 0 (1+ I) (= I 400)      ;Clear buffer
312    (PHYS-MEM-WRITE I 0))
313  (PRINT 'READ)
314  (DC-EXEC DC-READ 0 0 1 CCW-LOC 0 DC-ALL-ERROR-BITS UNIT)
315  (LET ((MA (DC-READ-MA)))
316    #M (DECLARE (FIXNUM MA))
317    (COND ((NOT (= MA 377))
318           (TERPRI) (PRINC '|MA wrong on read of pattern, correct=377, actual=|)
319           (PRIN1 MA) (TERPRI))))
320  ;; Check pattern read back into core, see if it's correct
321  (LET ((DCHECK-AND 37777777777) (DCHECK-IOR 0)  ;Accumulate error bits here
322        (DCHECK-ADR-AND 377) (DCHECK-ADR-IOR 0))
323    (DO I 0 (1+ I) (= I 40)     ;Loc 0-37 get floating 1's
324      (DCHECK-COMPARE I (#M LSH #Q ASH 1 I)))
325    (DO I 0 (1+ I) (= I 40)     ;Loc 40-77 get floating 0's
326      (DCHECK-COMPARE (+ 40 I) (- (#M LSH #Q ASH 1 32.) (#M LSH #Q ASH 1 I))))
327    (DO I 100 (1+ I) (= I 400)  ;Loc 100-377 get address pattern
328      (DCHECK-COMPARE I (+ (#M LSH #Q ASH (LOGXOR 377 I) 8) I)))
329    (DCHECK-PM '|Data bits dropped during write to or read from disk: |
330               (LOGXOR 37777777777 DCHECK-IOR))
331    (DCHECK-PM '|Data bits picked during write to or read from disk: |
332               DCHECK-AND)
333    (DCHECK-PM '|Address bits 0 with bad data during write to or read from disk: |
334               (LOGXOR 377 DCHECK-ADR-AND))
335    (DCHECK-PM '|Address bits 1 with bad data during write to or read from disk: |
336               DCHECK-ADR-IOR))
337  ;; Maybe there should be a test-loop for the above?
338  ;; part 7 - in case loser didn't look at the heads and see that they moved
339  ;; correctly during part 4, which is hard to do on a T-300, we will here
340  ;; assume we have a good pack and try reading from each power of 2 cylinder.
341  ;; This will get a header-compare error if a disk bus bit doesn't work.
342  (TERPRI)
343  (PRINC "Trying reads of various blocks; will get HEADER-COMPARE if disk bus bits bad")
344  (TERPRI)
345  (DC-EXEC DC-READ 0 0 0 CCW-LOC 0 DC-ALL-ERROR-BITS UNIT)
346  (PRINC " cyl 0 ")
347  (DO CYL 1 (LSH CYL 1) (= CYL 2000)
348    (DC-EXEC DC-READ CYL 0 0 CCW-LOC 0 DC-ALL-ERROR-BITS UNIT)
349    (PRINC " cyl ")
350    (PRIN1 CYL))
351  ;; end
352  (TERPRI)
353  (PRINC "You might enjoy trying DC-WRITE-READ-TEST")
354  (TERPRI)
355  (PRINC '|End of DCHECK.  Now run the format program and the ECC test program.|))
356
357(defun dc-read-cyl (cyl)
358    (DC-EXEC DC-READ CYL 0 0 CCW-LOC 0 DC-ALL-ERROR-BITS )
359    (PRINC " cyl ")
360    (PRIN1 CYL))
361
362(defun dc-read-block (cyl head block)
363    (DC-EXEC DC-READ CYL head block CCW-LOC 0 DC-ALL-ERROR-BITS )
364    (PRINC " cyl ")
365    (PRIN1 CYL)
366    (princ "   block ")
367    (prin1 block)
368    (princ "   head ")
369    (prin1 head))
370 
371(DEFUN DC-RESET NIL
372  (PHYS-MEM-WRITE DC-CMD-ADR DC-STOP)
373  (PHYS-MEM-WRITE DC-CMD-ADR 0))
374
375(DEFUN DC-RECALIBRATE (&OPTIONAL (UNIT 0))
376  (DC-EXEC DC-RECAL 0 0 0 0 NIL 0 UNIT)
377  (DO () ((NOT (BIT-TEST 1_8 (PHYS-MEM-READ DC-STS-ADR))))
378    (PROCESS-ALLOW-SCHEDULE)))
379
380(DEFUN DC-FAULT-CLEAR (&OPTIONAL (UNIT 0))
381  (DC-EXEC DC-FAULT-CLEAR 0 0 0 0 NIL 0 UNIT)
382  (DO () ((NOT (BIT-TEST 1_8 (PHYS-MEM-READ DC-STS-ADR))))
383    (PROCESS-ALLOW-SCHEDULE)))
384
385;;; Compare pattern, set special variables if lose
386;;; Also obeys CC-DIAG-TRACE
387(DEFUN DCHECK-COMPARE (ADR VAL)
388  (LET ((MASK (PHYS-MEM-READ ADR)))
389    (SETQ DCHECK-AND (LOGAND DCHECK-AND MASK)
390          DCHECK-IOR (LOGIOR DCHECK-IOR MASK))
391    (COND ((NOT (= MASK VAL))
392           (AND CC-DIAG-TRACE
393                (FORMAT T "~&Address ~O Good ~O Bad ~O~%" ADR VAL MASK))
394           (SETQ DCHECK-ADR-AND (LOGAND DCHECK-ADR-AND ADR)
395                 DCHECK-ADR-IOR (LOGIOR DCHECK-ADR-IOR ADR))))
396    NIL))
397
398;;; Print bit list given as mask
399(DEFUN DCHECK-PM (MESSAGE MASK &AUX CC-SUSPECT-BIT-LIST) ;CC-PRINT-BIT-LIST looks at it
400  (OR (ZEROP MASK)
401      (CC-PRINT-BIT-LIST MESSAGE
402                         (DO ((BITNO 0 (1+ BITNO))
403                              (L NIL))
404                             ((ZEROP MASK) L)
405                           (AND (ODDP MASK) (SETQ L (CONS BITNO L)))
406                           (SETQ MASK (#M LSH #Q ASH MASK -1))))))
407
408;;; Check that the block counter is counting, and producing
409;;; all the right values and only the right values.  This one
410;;; will not run in Maclisp.
411#Q
412(DEFUN DCHECK-BLOCK-COUNTER ()
413  (DO ((DESIRED-VALUES #10R  ;; Vandals: Yes, a value of 17. can appear here
414                                '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17))
415       (GOOD-VALUES NIL)
416       (BAD-VALUES NIL)
417       (MISSING-VALUES)
418       (BCTR)
419       (START-TIME (TIME)))
420      ((> (TIME-DIFFERENCE (TIME) START-TIME) 30.)      ;Run for 1/2 second
421       (SETQ GOOD-VALUES (SORT GOOD-VALUES #'<))
422       (SETQ BAD-VALUES (SORT BAD-VALUES #'<))
423       (SETQ MISSING-VALUES (COPYLIST DESIRED-VALUES))
424       (DOLIST (X GOOD-VALUES)
425         (SETQ MISSING-VALUES (DELQ X MISSING-VALUES)))
426       (AND (OR BAD-VALUES MISSING-VALUES)
427            (FORMAT T "~&Problems with block counter.  May be disk not spinning, lack of
428 index or sector pulse, or problem with block counter logic.~%"))
429       (AND BAD-VALUES (FORMAT T "Erroneous values seen (octal): ~{~O~^,~}~%" BAD-VALUES))
430       (AND MISSING-VALUES (FORMAT T "Values not seen (octal): ~{~O~^,~}
431Good values that were seen: ~{~O~^,~}~%" MISSING-VALUES GOOD-VALUES)))
432    (SETQ BCTR (LDB 3010 (PHYS-MEM-READ DC-STS-ADR)))
433    (IF (MEMQ BCTR DESIRED-VALUES)
434        (OR (MEMQ BCTR GOOD-VALUES) (PUSH BCTR GOOD-VALUES))
435        (OR (MEMQ BCTR BAD-VALUES) (PUSH BCTR BAD-VALUES)))))
436
437;;; Check address logic, return bits which failed
438(DEFUN DCHECK-CLP-ADR (ADR &OPTIONAL (UNIT 0))
439  (LET ((MA 0))
440    (DECLARE (FIXNUM MA))
441    (DC-EXEC DC-READ 0 0 0 ADR NIL 0 UNIT)
442    (COND ((NOT (= (LOGAND 14000000 (PHYS-MEM-READ-24 DC-STS-ADR))
443                   14000000))  ;NXM and CCW CYCLE
444           (DC-PRINT-STATUS) (TERPRI)
445           (PRINC '|NXM or CCW-CYCLE failure with CLP pointing to non-existent memory loc |)
446           (PRIN1 ADR)))
447    (SETQ MA (DC-READ-MA))
448    (COND ((NOT (= MA ADR))
449           (TERPRI)
450           (PRINC '|MA wrong on CLP nxm, probably address data path failure, correct=|)
451           (PRIN1 ADR)
452           (PRINC '|, actual=|)
453           (PRIN1 MA)
454           (LOGXOR MA ADR))
455          (T 0))))
456
457;Tight reading loop.
458(DEFUN DCHECK-HEADER-COMPARE-LOOP NIL
459 (DO () ((KBD-TYI-NO-HANG))
460   (DC-EXEC DC-READ 0 0 0 CCW-LOC 1000 0)))
461
462;Tight writing loop.  This is the same as the write in part 6 of DCHECK.
463(DEFUN DCHECK-WRITE-LOOP NIL
464  (DO I 0 (1+ I) (= I 40)                       ;Loc 0-37 get floating 1's
465      (PHYS-MEM-WRITE I (#M LSH #Q ASH 1 I)))
466  (DO I 0 (1+ I) (= I 40)                       ;Loc 40-77 get floating 0's
467      (PHYS-MEM-WRITE (+ 40 I) (- (#M LSH #Q ASH 1 32.) (#M LSH #Q ASH 1 I))))
468  (DO I 100 (1+ I) (= I 400)                    ;Loc 100-377 get address pattern
469      (PHYS-MEM-WRITE I (+ (LSH (LOGXOR 377 I) 8) I)))
470  (DO () ((KBD-TYI-NO-HANG))
471    (DC-EXEC DC-WRITE 0 0 1 CCW-LOC 0 DC-ALL-ERROR-BITS)
472    (LET ((MA (DC-READ-MA)))
473      (COND ((NOT (= MA 377))
474             (TERPRI) (PRINC '|MA wrong on write of pattern, correct=377, actual=|)
475             (PRIN1 MA))))))
476
477
478(defun dcheck-check-da-block-increments nil
479  (dotimes (block  blocks-per-track)
480    (cc-disk-xfer dc-read (+ (* 100 blocks-per-cylinder)
481                             block)
482                1 2)))
483
484(defun dcheck-check-da-head-increments nil
485  (dotimes (head (// blocks-per-cylinder blocks-per-track))
486    (cc-disk-xfer dc-read (+ (* 100 blocks-per-cylinder)
487                             (1- blocks-per-track)
488                             (* head blocks-per-track))
489                1 2)))
490
491(defun dcheck-check-da-cylinder-increments nil
492  (dotimes (cyl n-cylinders)
493    (cc-disk-xfer dc-read (+ (* cyl blocks-per-cylinder)
494                             (1- blocks-per-cylinder))
495                  1 2)))
496
497(defun dcheck-check-da-cylinder-increments-1 nil
498  (do ((adr 12 (1+ adr))
499       (core-page 1 (1+ core-page))
500       (n (* 2 blocks-per-cylinder) (1- n)))
501      ((= n 0))
502    (phys-mem-write adr (+ (cc-shift adr 8) (cond ((= n 1) 0) (t 1)))))
503  (dotimes (cyl (- n-cylinders 2))
504    (dc-exec dc-read cyl 0 0 12 nil dc-all-error-bits)))
505
506(DEFUN DCHECK-CCW-ADR (ADR &OPTIONAL (UNIT 0))
507  (LET ((MA 0))
508    (DECLARE (FIXNUM MA))
509    (DC-EXEC DC-READ 0 0 0 CCW-LOC (SETQ ADR (LOGAND 77777400 ADR)) 0 UNIT)
510    (COND ((NOT (= (LOGAND 14000000 (PHYS-MEM-READ-24 DC-STS-ADR))
511                   04000000))  ;NXM and -CCW CYCLE
512           (DC-PRINT-STATUS) (TERPRI)
513           (PRINC '|NXM or CCW-CYCLE failure with CCW pointing to non-existent memory loc |)
514           (PRIN1 ADR)))
515    (SETQ MA (DC-READ-MA))
516    (COND ((NOT (= MA ADR))
517           (TERPRI)
518           (PRINC '|MA wrong on CCW nxm, probably address data path failure, correct=|)
519           (PRIN1 ADR)
520           (PRINC '|, actual=|)
521           (PRIN1 MA)
522           (LOGXOR MA ADR))
523          (T 0))))
524
525;;; Alternating seek test
526(DEFUN DCHECK-SEEK (CYL &OPTIONAL (UNIT 0))
527  (TERPRI)
528  (PRINC '|Should be seeking between cylinders 0 and |)
529  (LET ((BASE 10.) (*NOPOINT NIL))
530    (PRIN1 CYL))
531  (PRINC '| - type space when OK. |)
532  (DO () (#M (NOT (ZEROP (LISTEN))) #Q (KBD-TYI-NO-HANG))
533    (DC-SEEK 0 UNIT)
534    (DC-SEEK CYL UNIT))
535  #M (TYI)
536  (TERPRI))
537
538;;; Basic XBUS errors call this guy, which prints a message and enters a test loop.
539(DEFUN DCHECK-ERR-LOOP (MESSAGE ADR VAL1 VAL2)
540  (TERPRI)
541  (PRINC MESSAGE)
542  (TERPRI)
543  (PRINC '|Now entering scope loop, writing |)
544  (PRIN1 VAL1)
545  (COND ((NOT (= VAL1 VAL2))
546         (PRINC '| and |)
547         (PRIN1 VAL2)))
548  (PRINC '| into |)
549  (PRIN1 ADR)
550  (PRINC '| and reading it back.|)
551  (DO () (#Q (KBD-TYI-NO-HANG) #M (LISTEN))
552    (PHYS-MEM-WRITE ADR VAL1)
553    (PHYS-MEM-READ ADR)
554    (PHYS-MEM-WRITE ADR VAL2)
555    (PHYS-MEM-READ ADR)))
556
557
558
559;;; ECC Test (in DCFU) error-message printer
560
561;;; This frob goes with the ECC tester in DCFU
562;;; He prints out the results of the log, which
563;;; are in page 28.
564;;; Each frob has status, ecc, bit mask, preceding word,
565;;; error word, next word.
566;;; The background is 0's.
567;;; The special variable ecc-wd-no is the bit corresponding
568;;; to a-ecc-wd in the ucode.
569
570(declare (special ecc-wd-no))
571
572(defun decode-ecc-logout ()
573  (do ((bitno 0 (1+ bitno))
574       (real-bitno (* 32. ecc-wd-no) (1+ real-bitno))
575       (logout-pntr (* 28. 400) (+ logout-pntr 6)))
576      ((= bitno 32.))
577    (declare (fixnum bitno real-bitno logout-pntr
578                     sts ecc msk prev-wd err-wd next-wd))
579    (let ((sts (phys-mem-read-24 logout-pntr))
580          (ecc (phys-mem-read (+ logout-pntr 1)))
581          (msk (phys-mem-read (+ logout-pntr 2)))
582          (prev-wd (phys-mem-read (+ logout-pntr 3)))
583          (err-wd (phys-mem-read (+ logout-pntr 4)))
584          (next-wd (phys-mem-read (+ logout-pntr 5))))
585      #M (or (= msk (lsh 1 bitno))
586             (break msk-bites-the-fucking-bag t))
587      (cond ((bit-test (logxor dc-all-error-bits 1_17) sts) ;all errs except ecc soft
588             (dc-print-status1 sts)
589             (format t '| error for bit ~D.| real-bitno))
590            ((not (LDB-TEST 1701 sts)) ;Bit 15.
591             (format t '|~%missing ecc soft error bit ~D.| real-bitno))
592            (t  ;Soft error, check pattern
593             (do ((pat (logldb 2013 ecc) (lsh pat -1))
594                  (pos (1- (logldb 0020 ecc)) (1+ pos)))
595                 ((oddp pat)
596                  (cond ((and (= pat 1) (= pos real-bitno)))
597                        (t (format t '|~%soft err wrong bit ~D., pos=~D.-1, pat=~O (i.e. ~D., ~O)|
598                                      real-bitno (logldb 0020 ecc)
599                                      (logldb 2013 ecc) pos pat))))
600               (declare (fixnum pos pat)))))
601      ;; Also check out the data read in
602      (and (> real-bitno 40)
603           (not (zerop prev-wd))
604           (format t '|~%For bit ~D., prev wd ~O should be 0|
605                     real-bitno prev-wd))
606      (and (not (= err-wd msk))
607           (format t '|~%For bit ~D., err wd ~O should be ~O|
608                     real-bitno err-wd msk))
609      (and (< real-bitno (- (* 256. 32.) 40))
610           (not (zerop next-wd))
611           (format t '|~%For bit ~D., next wd ~O should be 0|
612                     real-bitno next-wd))
613      )))
614
615;;; Read/Write test
616
617(defvar dc-write-read-trace t)
618(defvar dc-test-unit 0)
619
620;;; Low-level routine, does a write and a read and compares
621;;; Intended to run on Lisp machine.
622;;; Uses memory page 200 for buffer and loc 777 for CCW
623(defun dc-write-read-test-0 (cyl head blk pattern-func &aux offset)
624  (setq offset 100000)  ;use this page of main memory
625  ;; Trace
626  (and dc-write-read-trace
627       (format t '|~%WRITE-READ-TEST: unit=~O, cyl=~O, head=~O, blk=~O, pattern=~A|
628                 dc-test-unit cyl head blk pattern-func))
629  ;; Fill memory with pattern
630  (do i 0 (1+ i) (= i 400)
631    (phys-mem-write (+ offset i) (funcall pattern-func i)))
632  ;; Write it out
633  (dc-exec dc-write cyl head blk 777 (+ offset 0) dc-all-error-bits dc-test-unit)
634  (do i 0 (1+ i) (= i 400)
635      (phys-mem-write (+ offset i) 0))
636  ;; Read it back
637  (dc-exec dc-read cyl head blk 777 (+ offset 0) dc-all-error-bits dc-test-unit)
638  ;; Check pattern
639  (do ((i 0 (1+ i))
640       (good) (bad) (heading-printed nil))
641      ((= i 400))
642    (setq good (funcall pattern-func i)
643          bad (phys-mem-read (+ offset i)))
644    (cond ((not (= good bad))
645           (cond ((not heading-printed)
646                  (format t '|~% Compare error for ~A pattern, cyl ~O, head ~O, blk ~O:~%Loc    Good      Bad|
647                            pattern-func cyl head blk)
648                  (setq heading-printed t)))
649           (format t '|~%~3O  ~8O ~8O| i good bad)))))
650
651;;; Patterns for above
652(defun all-zero-pat (ignore) 0)
653(defun all-one-pat (ignore) 37777777777)
654(defun alt-bits-pat (ignore) 25252525252)
655(defun addr-pat (loc) (+ (lsh (logxor 377 loc) 8) loc))
656(defun floating-one-pat (loc) (logdpb 1 (1+ (lsh (\ loc 40) 6)) 0))
657(defun floating-zero-pat (loc) (logdpb 0 (1+ (lsh (\ loc 40) 6)) 37777777777))
658(declare (special gubbish))
659(setq gubbish 7700770066)
660(defun gubbish-pat (ignore) gubbish)
661
662;;; Uses memory page 200 for buffer and loc 777 for CCW
663(defun dc-read-test-0 (cyl head blk ignore &aux offset)
664  (setq offset 100000)  ;use this page of main memory
665  ;; Trace
666  (and dc-write-read-trace
667       (format t "~%READ-TEST: unit=~O, cyl=~O, head=~O, blk=~O"
668                 dc-test-unit cyl head blk))
669  ;; Read it
670  (dc-exec dc-read cyl head blk 777 (+ offset 0) dc-all-error-bits dc-test-unit)
671)
672
673;;; An address specifier is a single number, a list of cases,
674;;; or a list of DO, first, last, optional increment,
675;;; or (on typein) ALL which translates into such.
676;;; We cons current state onto the front
677;;; First value is next value output from spec, second value is T if wrapped around
678(defun dc-step-addr-spec (frob)
679  (prog ((current (car frob)) (spec (cdr frob)))
680    (cond ((atom spec)
681           (return spec t))
682          ((not (eq (car spec) 'do)) ;Cases list
683           (and (null current) (setq current 0))
684           (return (nth current spec)
685                   (progn (setq current (1+ current))
686                          (cond ((>= current (length spec))
687                                 (rplaca frob 0) t)
688                                (t (rplaca frob current) nil)))))
689          (t (and (null current) (setq current (cadr spec)))
690             (return current
691                     (progn (setq current (+ current (or (cadddr spec) 1)))
692                            (cond ((>= current (caddr spec))
693                                   (rplaca frob (cadr spec)) t)
694                                  (t (rplaca frob current) nil))))))))
695
696;;; Step a bunch of addr specs, return list of current state of each one.
697;;; First steps first, list returned is in reverse order
698(defun dc-step-addr-specs (specs)
699  (do ((l specs (cdr l))
700       (val)(wrap-p)
701       (r nil))
702      ((null l) r)
703    (multiple-value (val wrap-p) (dc-step-addr-spec (car l)))
704    (setq r (cons val r))
705    (cond ((not wrap-p)  ;Rest don't step
706           (return (do ((l (cdr l) (cdr l))
707                        (current) (spec)
708                        (r r))
709                       ((null l) r)
710                     (setq current (caar l) spec (cdar l))
711                     (setq r (cons (cond ((atom spec) spec)
712                                         ((eq (car spec) 'do)
713                                          (or current (cadr spec)))
714                                         (t (and (null current) (setq current 0))
715                                            (and (>= current (length spec)) (setq current 0))
716                                            (nth current spec)))
717                                   r))))))))
718
719(defun dc-get-addr-spec (prompt all &optional response)
720  (let ((spec (cond (response)
721                    (t
722                      (format t '|~% ~A:| prompt)
723                      (cond ((= (tyipeek) #/?)
724                             (tyi)
725                             (prin1 all)))
726                      (si:read-for-top-level)))))
727    (and (eq spec 'all) (setq spec all))
728    (cons nil spec)))
729
730(defun dc-get-addr-specs (response-list all-list &optional no-pattern)
731 (prog nil
732  (let ((cyl (dc-get-addr-spec '|Cylinders|
733                               (first all-list)
734                               (first response-list)))
735        (head (dc-get-addr-spec '|Heads|
736                                (second all-list)
737                                (second response-list)))
738        (blk (dc-get-addr-spec '|Blocks (sectors)|
739                               (third all-list)
740                               (third response-list)))
741        (pattern-func (if no-pattern (cons nil nil)
742                          (dc-get-addr-spec '|Pattern func|
743                                            '(all-zero-pat all-one-pat alt-bits-pat
744                                              addr-pat floating-one-pat floating-zero-pat
745                                              gubbish-pat)
746                                            (fourth response-list)))))
747    (return cyl head blk pattern-func))))
748
749;;; User interface to write-read test
750;;; This version is kludged up, you should step only one addr at a time!
751(defun dc-write-read-test (&optional response-list
752                                     (all-list '( (do 0 815.)
753                                                 (do 0 5)
754                                                 (do 0 17.) )))
755  (multiple-value-bind (cyl head blk pattern-func)
756      (dc-get-addr-specs response-list all-list)
757    (do () ((kbd-char-available))
758      (apply 'dc-write-read-test-0
759             (dc-step-addr-specs (list pattern-func blk head cyl))))))
760
761(defun dc-wrt ()
762  (dc-write-read-test '(all all all all)))
763
764(defun dc-read-test (&optional response-list (all-list '( (do 0 815.)
765                                                         (do 0 5)
766                                                         (do 0 17.) )))
767  (multiple-value-bind (cyl head blk pattern-func)
768      (dc-get-addr-specs response-list all-list T)
769    (do () ((kbd-char-available))
770      (apply 'dc-read-test-0
771             (dc-step-addr-specs (list pattern-func blk head cyl))))))
772
773;Useful for debugging disk problems, particularly read-compare errors
774(defvar copy-page-buffer)
775
776(defun copy-page (start-address)
777  (or (boundp 'copy-page-buffer) (setq copy-page-buffer (make-array nil 'art-q page-size)))
778  (dotimes (i page-size)
779    (aset (phys-mem-read (+ start-address i)) copy-page-buffer i)))
780
781(defun compare-page (start-address)
782  (dotimes (i page-size)
783    (let ((old (aref copy-page-buffer i))
784          (new (phys-mem-read (+ start-address i))))
785      (cond ((not (= old new))
786             (format t "~&~O// old ~O new ~O, xor ~O bits "
787                       (+ start-address i) old new (logxor old new))
788             (do ((bitlist nil)
789                  (bits (logxor old new))
790                  (bitno 0 (1+ bitno)))
791                 ((= bitno 32.)
792                  (cc-print-bit-list "" bitlist))
793               (and (bit-test (ash 1 bitno) bits)
794                    (push bitno bitlist))))))))
795
796(defun dc-repeat-read (cyl head sec &optional (error-bits dc-all-error-bits)
797                                    &aux (offset 100000))
798  (do () (())
799    (dc-exec dc-read cyl head sec 777 (+ offset 0) error-bits)))
800
801;;; Formatting stuff
802;;; This is too slow for bulk use, but useful for figuring out how you've lost.
803
804;Routines to access "buffer" memory, which is a bunch of halfwords
805;starting at XBUS address zero.
806
807;Since things seem very marginal, and for speed, we copy the stuff in and out
808;of an array, being careful while copying.
809
810(declare (special buffer-hwd buffer-bit))
811(or (boundp 'buffer-hwd)    ;20. pages for decode-track plus 1 for channel program
812    (setq buffer-hwd (make-array nil 'art-16b (* 1000 21.))
813          buffer-bit (make-array nil 'art-1b (* 1000 21. 16.)
814                                 buffer-hwd)))
815
816;Get buffer out of other machine
817(defun get-buffer ()
818  (dbg-reset-status)
819  (do ((i 0 (1+ i))
820       (tem) (tem1)
821       (n (array-length buffer-hwd)))
822      ((= i n))
823    (setq tem (rd-buffer i)
824          tem1 (rd-buffer i))
825    (or (= tem tem1)
826        (ferror nil "Halfword ~O read as ~O and as ~O" i tem tem1))
827    (as-1 tem buffer-hwd i))
828  (dbg-print-status))
829
830;Put buffer into other machine
831(defun put-buffer ()
832  (dbg-reset-status)
833  (do ((i 0 (1+ i))
834       (tem)(tem1)
835       (n (array-length buffer-hwd)))
836      ((= i n))
837    (wr-buffer i (setq tem (ar-1 buffer-hwd i)))
838    (setq tem1 (rd-buffer i))
839    (or (= tem tem1)
840        (ferror nil "Halfword ~O wrote ~O read back as ~O" i tem tem1)))
841  (dbg-print-status))
842
843(defun rd-buffer (loc)
844  (let ((ubus-loc (dbg-setup-unibus-map 17 (lsh loc -1))))
845     (cond ((zerop (logand 1 loc))
846            (dbg-read ubus-loc))
847           (t (dbg-read ubus-loc)
848              (dbg-read (+ ubus-loc 2))))))
849
850(defun wr-buffer (loc val)
851  (let ((ubus-loc (dbg-setup-unibus-map 17 (lsh loc -1))) (tem))
852     (cond ((zerop (logand 1 loc))
853            (dbg-read ubus-loc)
854            (dbg-write ubus-loc val)
855            (dbg-write (+ ubus-loc 2) (setq tem (dbg-read (+ ubus-loc 2))))
856            ;(ck-buffer loc val tem (dbg-read ubus-loc) (dbg-read (+ ubus-loc 2)))
857            )
858           (t (dbg-write ubus-loc (setq tem (dbg-read ubus-loc)))
859              (dbg-write (+ ubus-loc 2) val)
860              ;(ck-buffer loc tem val (dbg-read ubus-loc) (dbg-read (+ ubus-loc 2)))
861              ))))
862
863(defun ck-buffer (loc good1 good2 wd1 wd2)
864     (or (and (= good1 wd1)
865              (= good2 wd2))
866         (ferror nil "Loc ~O wrote ~O,,~O, read ~O,,~O" loc good2 good1 wd2 wd1)))
867
868;Given a loc in the buffer, and a disk address, store a sector whose header
869;claims it is at that address, and return the advanced loc.
870;This uses the copy of the buffer in this machine.
871(defun store-sector (loc cyl head blk next-address-code)
872  ;;Preamble+VFO lock is 61. bytes of 1's, followed by sync which is a 177
873  (do i 30. (1- i) (= i 0)              ;Store 60. bytes (30. halfwords) of 1's
874    (as-1 177777 buffer-hwd loc)
875    (setq loc (1+ loc)))
876  (as-1 077777 buffer-hwd loc)          ;One byte of 1's and a byte of 177
877  (setq loc (1+ loc))
878  ;;Header.  A 32-bit word, see the manual for format.
879  ;;Followed by 32 bits of ecc.
880  (let ((head1 (+ (lsh head 8) blk))
881        (head2 (+ (lsh next-address-code 14.) cyl))
882        (ecc1 0)
883        (ecc2 0))
884     (as-1 head1 buffer-hwd loc)
885     (as-1 head2 buffer-hwd (1+ loc))
886     (multiple-value (ecc1 ecc2) (ecc16 head1 ecc1 ecc2))
887     (multiple-value (ecc1 ecc2) (ecc16 head2 ecc1 ecc2))
888     (as-1 ecc1 buffer-hwd (+ loc 2))
889     (as-1 ecc2 buffer-hwd (+ loc 3))
890     (setq loc (+ loc 4)))
891  ;;VFO Relock - 20. bytes of 1's
892  (do i 10. (1- i) (= i 0)
893    (as-1 177777 buffer-hwd loc)
894    (setq loc (1+ loc)))
895  ;;Sync (177) and pad (377)
896  (as-1 177577 buffer-hwd loc)
897  (setq loc (1+ loc))
898  ;;Data field - 1024. bytes of zeros.
899  (do i 512. (1- i) (= i 0)
900    (as-1 0 buffer-hwd loc)
901    (setq loc (1+ loc)))
902  ;;Data ecc, doesn't matter anyway, we'll just write zero (which is right for zero)
903  (as-1 0 buffer-hwd loc)
904  (setq loc (1+ loc))
905  (as-1 0 buffer-hwd loc)
906  (setq loc (1+ loc))
907  ;;Postamble, 44. bytes of 1's
908  (do i 22. (1- i) (= i 0)
909    (as-1 177777 buffer-hwd loc)
910    (setq loc (1+ loc)))
911  loc)
912
913;Compute ECC for 16 bits, given previous ecc halfword pair and returning new
914(defun ecc16 (hwd ecc1 ecc2)
915  (do ((i 16. (1- i))
916       (hwd hwd (lsh hwd -1))
917       (bit) (poly1) (poly2))
918      ((zerop i) (return ecc1 ecc2))
919    (setq bit (logxor (logand 1 hwd) (logand 1 ecc1)))  ;ecc.in
920    (setq poly1 (* bit 002400)  ;1's in bits 8, 10
921          poly2 (* bit 120020)) ;1's in bits 20, 29, 31
922    (setq ecc1 (+ (lsh ecc1 -1) ;Shift double right 1
923                  (lsh (logand 1 ecc2) 15.))
924          ecc2 (lsh ecc2 -1))
925    (setq ecc1 (logxor ecc1 poly1)
926          ecc2 (logxor ecc2 poly2))))
927
928;Format a track.  Method is call store-sector enough times
929;to make most of the 20160. bytes of the track (better to err on the side
930;of less than more.)  Then set up a channel program and run the disk
931;to write it all out.
932(defun format-track (cyl head &aux loc)
933  ;;First page is used for channel program
934  (setq loc 1000) ;halfwords
935  (do blk 0 (1+ blk) (= blk 17.)
936    (setq loc (store-sector loc cyl head blk
937                            (cond ((< blk 16.) 0) ;next block same track
938                                  ((< head 4) 1) ;block 0 next track
939                                  ((< cyl 815.) 2) ;block 0, head 0, next cylinder
940                                  (t 3)))))    ;end of disk
941  (put-buffer) ;ship it over
942  ;;Always write 19 pages, somewhat of a crock, should look at loc
943  (do i 0 (1+ i) (= i 19.)
944    (dbg-write-xbus i (+ (lsh (1+ i) 8)
945                         (cond ((= i 18.) 0) (t 1)))))
946  ;;Do it
947  (dc-exec dc-write-all cyl head 0 0 nil dc-some-error-bits)
948  )
949
950(declare (special trklen))
951(setq trklen (* 20160. 8))
952
953;This function reads in a track and types out some approximation of what's on it
954;If cyl is nil, decode what's in core
955(defun decode-track (cyl head &optional (blk 0) (unit 0))
956  (cond ((not (null cyl))
957         ;; First, read in 20. blocks, which is more than 20160. bytes
958         (do i 0 (1+ i) (= i 20.)
959           (dbg-write-xbus i (+ (lsh (1+ i) 8)
960                                (cond ((= i 19.) 0) (t 1))))) 
961         (dc-exec dc-read-all cyl head blk 0 nil dc-some-error-bits unit)
962         (get-buffer) ;gobble it down from other machine
963         ))
964  ;; Map over sectors
965  (do ((loc 0)
966       (hwd1) (hwd2))
967      ((or (> loc trklen) (kbd-tyi-no-hang)))
968    (setq loc (decode-sync loc))
969    (cond ((< loc trklen)
970           (setq hwd1 (rd-hwd loc)
971                 hwd2 (rd-hwd (setq loc (+ loc 20)))
972                 loc (+ loc 20))
973           (format t "~%Header: ~O,,~O" hwd2 hwd1)
974           (setq hwd1 (rd-hwd loc)
975                 hwd2 (rd-hwd (setq loc (+ loc 20)))
976                 loc (+ loc 20))
977           (format t " ... ecc ~O,,~O" hwd2 hwd1)
978           (setq loc (decode-sync loc)) ;VFO relock
979           (format t "~% Pad, data, ecc: ")
980           (decode-bits loc (* 8 1029.))
981           (setq loc (+ loc (* 8 1029.)))))))
982
983;Get a bit out of the buffer, given a bit loc
984(defmacro rd-bit (loc)
985  `(ar-1 buffer-bit (+ 20000 ,loc)))  ;8K bits of first page skipped
986
987(defmacro wr-bit (loc val)
988  `(as-1 ,val buffer-bit (+ 20000 ,loc)))  ;8K bits of first page skipped
989
990;Get a 16-bit halfword, given a bit loc.
991(defun rd-hwd (loc)
992  (do ((hwd 0 (+ (lsh hwd -1) (lsh (rd-bit (+ loc i)) 15.)))
993       (i 0 (1+ i)))
994      ((= i 20) hwd)))
995
996;Just type out some bits run-length encoded
997(defun decode-bits (loc nbits)
998  ;;Do forever, until field exhausted
999  (do ((endloc (+ loc nbits)))
1000      ((>= loc endloc))
1001    ;;Skip zeros
1002    (do ((zerc 0 (1+ zerc)))
1003        ((or (>= loc endloc)
1004             (not (zerop (rd-bit loc))))
1005         (or (zerop zerc)
1006             (format t "~D zeros " zerc)))
1007      (setq loc (1+ loc)))
1008    ;;Skip ones
1009    (do ((onec 0 (1+ onec)))
1010        ((or (>= loc endloc)
1011             (zerop (rd-bit loc)))
1012         (or (zerop onec)
1013             (format t "~D ones " onec)))
1014      (setq loc (1+ loc)))))
1015
1016;Find a sync, type out 1's and 0's
1017;A sync is at least 64 1's followed by a 0.
1018(defun decode-sync (loc)
1019  (and (zerop (rd-bit loc))             ;Skip leading zeros
1020       (do ((zerc 1 (1+ zerc)))
1021           ((or (not (zerop (rd-bit (setq loc (1+ loc)))))
1022                (> loc trklen))
1023            (format t "~%~D zeros" zerc))))
1024  (do ((onec 1 (1+ onec)))              ;Skip ones
1025      ((or (zerop (rd-bit (setq loc (1+ loc))))
1026           (> loc trklen))
1027       (format t "~%~D ones" onec)
1028       (cond ((> loc trklen) loc)
1029             ((>= onec 64.)
1030              (format t " 1 zero")
1031              (1+ loc)) ;Skip the zero
1032             (t (decode-sync loc))))))
1033
1034;Simulated ECC errors.
1035(declare (special rd-all-wrt-all-offset))
1036(setq rd-all-wrt-all-offset 4)  ;Offset in halfwords
1037
1038;The method is to read in a whole track, as 20 pages, then shift it down
1039;in buffer memory by the offset, to compensate for the way the hardware works.
1040;Next, find a specified bit in the data area of sector 0 and corrupt it.
1041;Then write the whole track back, as 19 pages.  This destroys sector 16., unfortunately.
1042;Now, read in sector 0, take the ECC error, and see if it is the correct bit.
1043
1044;This function gets a track into core and offsets it
1045(defun read-whole-track (cyl head)
1046  ;; First, read in 20. blocks, which is more than 20160. bytes
1047  (do i 0 (1+ i) (= i 20.)
1048    (dbg-write-xbus i (+ (lsh (1+ i) 8)
1049                         (cond ((= i 19.) 0) (t 1))))) 
1050  (dc-exec dc-read-all cyl head 0 0 nil dc-some-error-bits)
1051  (get-buffer) ;gobble it down from other machine
1052  ;; Offset the buffer (not the first page)
1053  (do i (1- 25000) (1- i) (= i 1000)
1054    (as-1 (cond ((>= (- i rd-all-wrt-all-offset) 1000)
1055                 (ar-1 buffer-hwd (- i rd-all-wrt-all-offset)))
1056                (t 177777))
1057                buffer-hwd i))
1058  )
1059
1060;This function writes a track back out
1061(defun write-whole-track (cyl head)
1062  (put-buffer) ;ship it over
1063  ;;Always write 19 pages, somewhat of a crock, should look at loc
1064  (do i 0 (1+ i) (= i 19.)
1065    (dbg-write-xbus i (+ (lsh (1+ i) 8)
1066                         (cond ((= i 18.) 0) (t 1)))))
1067  ;;Do it
1068  (dc-exec dc-write-all cyl head 0 0 nil dc-some-error-bits)
1069  )
1070
1071;This function finds the start of sector 0 in the buffer and corrupts
1072;a specified bit in it.
1073;Find 64 1's, followed by a 0.  Skip 64-bit header, again find 64 1's
1074;followed by a 0.  Skip 8 bits and you are at the first data bit.
1075(defun corrupt-bit (bitno)
1076  (let ((start (+ 8. (find-sync (+ 64. (find-sync 0))))))
1077    (wr-bit (+ start bitno) (- 1 (rd-bit (+ start bitno))))))
1078
1079;This function tests 1 bit
1080(defun test-ecc-1 (cyl head bitno)
1081  (read-whole-track cyl head)
1082  (corrupt-bit bitno)
1083  (write-whole-track cyl head)
1084  ;; Now read block 0 into page 1
1085  (dbg-write-xbus 0 400)
1086  (dc-exec dc-read cyl head 0 0 nil dc-some-error-bits)
1087  (let ((sts (phys-mem-read-24 dc-sts-adr))
1088        (ecc-loc (phys-mem-read dc-ecc-adr))
1089        ecc-pat)
1090    (setq ecc-pat (ldb 2020 ecc-loc)
1091          ecc-loc (ldb 0020 ecc-loc))
1092    (cond ((not (and (bit-test (lsh 1 15.) sts) ;ECC-SOFT should be set
1093                     (not (bit-test (lsh 476775 6) sts)))) ;IPE, ECC-HARD, etc. should not be
1094           (dc-print-status1 sts))
1095          ((zerop ecc-pat) (format t "~%Error, ecc-pat is 0, loc=~O~%" ecc-loc))
1096          ((do ((loc ecc-loc (1+ loc))
1097                (pat ecc-pat (lsh pat -1)))
1098               ((oddp pat)
1099                (cond ((not (= pat 1))
1100                       (format t "~%Error, more than one bit on in pat, pat=~O, loc=~O~%"
1101                                 pat loc))
1102                      ((not (= loc bitno))
1103                       (format t "~%Error, wrong bit number, pat=1, loc=~O~%" loc))
1104                      (t  ;OK
1105                       ))))))))
1106
1107;This function stores specified crud in sector 0
1108(defun fill-sec0 (cyl head patname)
1109  (do i 0 (1+ i) (= i 1000)
1110    (wr-buffer (+ i 1000)
1111               (selectq patname
1112                 (zero 0)
1113                 (one 177777)
1114                 (addr i)
1115                 (caddr (logxor 177777 i))
1116                 (rot1 (lsh 1 (\ i 20)))
1117                 (rot0 (logxor 177777 (lsh 1 (\ i 20))))
1118                 (otherwise (ferror nil "Unknown pattern name ~S, try zero, one, addr, caddr, rot1, or rot0" patname)))))
1119  (dc-exec dc-write cyl head 0 0 400 dc-all-error-bits))
1120
1121;This function finds a sync pattern, which is at least 64 1's followed by a 0.
1122(defun find-sync (loc)
1123  (and (zerop (rd-bit loc))             ;Skip leading zeros
1124       (do ((zerc 1 (1+ zerc)))
1125           ((or (not (zerop (rd-bit (setq loc (1+ loc)))))
1126                (> loc trklen)))))
1127  (do ((onec 1 (1+ onec)))              ;Skip ones
1128      ((or (zerop (rd-bit (setq loc (1+ loc))))
1129           (> loc trklen))
1130       (cond ((> loc trklen) loc)
1131             ((>= onec 64.)
1132              (1+ loc)) ;Skip the zero
1133             (t (find-sync loc))))))
Note: See TracBrowser for help on using the repository browser.