Context Navigation

dcheck.lisp @ 216

Revision 216, 40.8 KB (checked in by rjs, 21 months ago)
Version 79.

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

Note: See TracBrowser for help on using the browser.

Download in other formats:

Original Format