Changeset 204

Timestamp:

08/18/11 04:36:51 (21 months ago)

Author:

rjs

Message:

Update.

Location:

trunk/lisp/lcadr

Files:

• ccdisk.lisp (modified) (1 diff)
• cload.lisp (modified) (1 diff)
• diags.lisp (modified) (3 diffs)
• dmon.lisp (modified) (1 diff)
• lcadmc.lisp (modified) (2 diffs)
• lcadrd.lisp (modified) (1 diff)
• ldbg.lisp (modified) (2 diffs)
• lqfmac.lisp (modified) (2 diffs)
• nldbg.lisp (modified) (8 diffs)
• packed.lisp (modified) (1 diff)
• praid.lisp (modified) (1 diff)
• promh.lisp (modified) (4 diffs)
• qf.lisp (modified) (2 diffs)
• ucadlr.lisp (deleted)

trunk/lisp/lcadr/ccdisk.lisp

@@ -590 +590 @@
   (SETQ CC-DISK-TYPE NIL)))
 
-(IF-FOR-LISPM (ADD-INITIALIZATION "CADR" '(CC-INITIALIZE-ON-STARTUP) '(COLD)))
+(IF-FOR-LISPM (ADD-INITIALIZATION "CADR" '(CC-INITIALIZE-ON-STARTUP) '(BEFORE-COLD)))

trunk/lisp/lcadr/cload.lisp

@@ -220 +220 @@
    ;OTHER AREAS
         COLD-EXTRA-PDL-AREA 10
-        COLD-MICRO-CODE-ENTRY-AREA 1
-        COLD-MICRO-CODE-ENTRY-NAME-AREA 1
-        COLD-MICRO-CODE-ENTRY-ARGS-INFO-AREA 1
-        COLD-MICRO-CODE-ENTRY-MAX-PDL-USAGE 1
+        COLD-MICRO-CODE-ENTRY-AREA 2
+        COLD-MICRO-CODE-ENTRY-NAME-AREA 2
+        COLD-MICRO-CODE-ENTRY-ARGS-INFO-AREA 2
+        COLD-MICRO-CODE-ENTRY-MAX-PDL-USAGE 2
         COLD-MICRO-CODE-EXIT-AREA 0
     ))

trunk/lisp/lcadr/diags.lisp

@@ -41 +41 @@
         CC-TEST-PP-DP CC-TEST-PI-DP CC-TEST-PDL-DP CC-TEST-Q-DP CC-TEST-C-MEM-DP
         CC-TEST-LC-DP CC-TEST-A-PASS-DP CC-TEST-M-PASS-DP
+        CC-TEST-ALU-SHIFT-LEFT-DP CC-TEST-ALU-SHIFT-RIGHT-DP
         CC-TEST-UNIBUS-MAP-DP CC-TEST-BUSINT-BUFFERS-DP))
 (SETQ ALL-MEMORIES
@@ -219 +220 @@
 (DEFUN CC-TEST-M-PASS-DP ()
   (CC-TEST-DATA-PATH "->L->MPASS->MF->M->ALU" '(CC-M-PASS-HANDLER) 32.))
+
+(DEFUN CC-TEST-ALU-SHIFT-LEFT-DP ()
+  (CC-TEST-DATA-PATH "MD,Q(31) -> ALU-SHIFT-LEFT-1" '(CC-ALU-SHIFT-LEFT-HANDLER) 32.))
+
+(DEFUN CC-TEST-ALU-SHIFT-RIGHT-DP ()
+  (CC-TEST-DATA-PATH "MD -> M+M -> ALU-SHIFT-RIGHT-1" '(CC-ALU-SHIFT-RIGHT-HANDLER) 32.))
 
 (DEFUN CC-TEST-UNIBUS-MAP-DP ()
@@ -271 +278 @@
                (FORMAT T "~%M-PASS WROTE ~S READ ~S" DATA ACTUAL)))
         ACTUAL))
+    (OTHERWISE (FERROR NIL "UNKNOWN OP"))))
+
+(DEFUN CC-ALU-SHIFT-LEFT-HANDLER (OP DATA)
+  (SELECTQ OP
+    (WRITE-READ
+     (CC-WRITE-Q (ASH (LOGAND DATA 1) 31.))     ;low bit to high bit of Q
+     (CC-WRITE-MD (ASH DATA -1))
+     (CC-EXECUTE                                ;NOTE NO WRITE, JUST PUT IT IN IR
+       CONS-IR-M-SRC CONS-M-SRC-MD
+       CONS-IR-ALUF CONS-ALU-SETM 
+       CONS-IR-OB CONS-OB-ALU-LEFT-1)
+     (LET ((ACTUAL (CC-READ-OBUS)))
+       (COND ((AND CC-DIAG-TRACE (NOT (= ACTUAL DATA)))
+              (FORMAT T "~%ALU-LEFT WROTE ~S READ ~S" DATA ACTUAL)))
+       ACTUAL))
+    (OTHERWISE (FERROR NIL "UNKNOWN OP"))))
+
+(DEFUN CC-ALU-SHIFT-RIGHT-HANDLER (OP DATA)
+  (SELECTQ OP
+    (WRITE-READ
+     (CC-WRITE-MD DATA)
+     (CC-EXECUTE
+       CONS-IR-M-SRC CONS-M-SRC-MD
+       CONS-IR-ALUF CONS-ALU-M+M
+       CONS-IR-OB CONS-OB-ALU-RIGHT-1)
+     (LET ((ACTUAL (CC-READ-OBUS)))
+       (COND ((AND CC-DIAG-TRACE (NOT (= ACTUAL DATA)))
+              (FORMAT T "~%ALU-RIGHT WROTE ~S READ ~S" DATA ACTUAL)))
+       ACTUAL))
     (OTHERWISE (FERROR NIL "UNKNOWN OP"))))
 

trunk/lisp/lcadr/dmon.lisp

@@ -12 +12 @@
        (COND ((NULL ALREADY-LOADED)
               (CC-ZERO-ENTIRE-MACHINE)
-              (CC-UCODE-LOADER NIL '(MEMD ULOAD DSK LISPM1) NIL)))
+              (CC-UCODE-LOADER NIL "AI:LISPM1;MEMD ULOAD" NIL)))
        (COND ((ZEROP MAP-OFFSET) (CC-FAST-LOAD-STRAIGHT-MAP))
              (T (CC-LOAD-STRAIGHT-MAP MAP-OFFSET)))

trunk/lisp/lcadr/lcadmc.lisp

@@ -190 +190 @@
   CONS-IR-ALUF 0207  ;INCLUDING CARRY
     CONS-ALU-SETZ 0_1
+    CONS-ALU-AND 1_1
+    CONS-ALU-SETM 3_1
+    CONS-ALU-SETA 5_1
+    CONS-ALU-XOR 6_1
+    CONS-ALU-IOR 7_1
     CONS-ALU-SETO 17_1
-    CONS-ALU-SETA 5_1
-    CONS-ALU-SETM 3_1
     CONS-ALU-SUB 55           ;includes ALU-CARRY-IN-ONE
     CONS-ALU-ADD 31_1
@@ -198 +201 @@
     CONS-ALU-M+M+1 77
     CONS-ALU-M+1 71
+    CONS-ALU-MSTEP 100
+    CONS-ALU-DSTEP 102
+    CONS-ALU-RSTEP 112
+    CONS-ALU-DFSTEP 122
   CONS-IR-Q 0002
     CONS-Q-LEFT 1

trunk/lisp/lcadr/lcadrd.lisp

@@ -1325 +1325 @@
 (DEFUN CC-SHOW-MODE (ARG)
   (AND CC-LOW-LEVEL-FLAG (PRIN1-THEN-SPACE 'LOW-LEVEL-MODE))
-  (CC-TYPE-OUT (OR ARG CC-MODE-REG) CC-MODE-REG-DESC NIL))
+  (CC-TYPE-OUT (OR ARG CC-MODE-REG) CC-MODE-REG-DESC NIL T))
 
 (DEFPROP CHMODE CC-EDIT-MODE CC-COLON-CMD)

trunk/lisp/lcadr/ldbg.lisp

@@ -90 +90 @@
 
 ;;; Print the error status bits
-(DEFVAR SERIAL-STREAM (SI:MAKE-SERIAL-STREAM
-                        ':PARITY NIL ':NUMBER-OF-DATA-BITS 8 ':BAUD 300.))
+(DEFVAR SERIAL-STREAM)
 
 (DEFUN DBG-PRINT-STATUS ()
@@ -122 +121 @@
 ;;; Dummy stream for SERIAL I/O
 (DEFUN SERIAL-STREAM (OP &OPTIONAL ARG1)
+  ;; Don't do this at load time since it doesn't work if the machine doesn't have
+  ;; the serial interface hardware
+  (OR (BOUNDP 'SERIAL-STREAM)
+      (SETQ SERIAL-STREAM (SI:MAKE-SERIAL-STREAM ':PARITY NIL ':NUMBER-OF-DATA-BITS 8
+                                                 ':BAUD 300.)))
   (SELECTQ OP
     (:WHICH-OPERATIONS '(TYI TYO))

trunk/lisp/lcadr/lqfmac.lisp

@@ -1 @@
-;;;-*-LISP-*-    macros for QF, CC: version of console program that runs on machine
-;       ** (c) Copyright 1980 Massachusetts Institute of Technology **
+;;; -*- Mode:Lisp; Package:CADR; Base:8 -*-
+;;;     ** (c) Copyright 1980 Massachusetts Institute of Technology **
+;;; ***CAUTION!! This file runs only on LISPM.  The MACLISP version is LMCONS;QFMAC***
+;;;    macros for QF, CC: version of console program that runs on machine
+
 
 ;SPECIAL VARIABLES FOR ARRAY STUFF
@@ -98 +101 @@
      ,ITEM))
 
+
+;Really wants to be a bignum LSH.  On LISPM, LSH doesnt win for bignums, ASH does.
+; In MACLISP, LSH wins sufficiently.
+(DEFMACRO CC-SHIFT (QUAN AMT)
+  `(#Q ASH #M LSH ,QUAN ,AMT))

trunk/lisp/lcadr/nldbg.lisp

@@ -32 +32 @@
       DBG-DL11-HIGH-BIT -1
       DBG-HOST NIL
-      DBG-CHAOS-STRING (STRING-APPEND "$ UISCAADD")
-      DBG-CHAOS-16 (MAKE-ARRAY NIL 'ART-16B 5 DBG-CHAOS-STRING)
+      DBG-CHAOS-STRING (MAKE-ARRAY NIL 'ART-STRING
+                                   (* 2 CHAOS:MAX-DATA-WORDS-PER-PKT) NIL '(2))
+      DBG-CHAOS-16 (MAKE-ARRAY NIL 'ART-16B  CHAOS:MAX-DATA-WORDS-PER-PKT DBG-CHAOS-STRING)
       DBG-UNIQUE-ID NIL)
 
@@ -42 +43 @@
 
 ;;; Read a location on the debuggee's Unibus
-(DEFUN DBG-READ (ADR)
+(DEFUN DBG-READ (ADR &OPTIONAL (CHAOS-DBG-TYPE 'DATA))
   (SELECTQ DBG-ACCESS-PATH
     (DL11
@@ -53 +54 @@
       (%UNIBUS-READ 766100))
     (CHAOS
-      (LET ((PKT (DBG-CHAOS 'DATA ADR)))
+      (LET ((PKT (DBG-CHAOS CHAOS-DBG-TYPE ADR)))
         (PROG1 (AREF PKT CHAOS:FIRST-DATA-WORD-IN-PKT)
                (CHAOS:RETURN-PKT PKT))))
     (OTHERWISE (FERROR NIL "~A is illegal DBG-ACCESS-PATH" DBG-ACCESS-PATH))))
 
-
 ;;; Write a location on the debuggee's Unibus
-(DEFUN DBG-WRITE (ADR VAL)
+(DEFUN DBG-WRITE (ADR VAL &OPTIONAL (CHAOS-DBG-TYPE 'DATA))
   (SELECTQ DBG-ACCESS-PATH
     (DL11
@@ -70 +70 @@
       (%UNIBUS-WRITE 766100 (LOGAND VAL 177777)))
     (CHAOS
-      (CHAOS:RETURN-PKT (DBG-CHAOS 'DATA ADR VAL)))
+     (DBG-CHAOS CHAOS-DBG-TYPE ADR VAL))
     (OTHERWISE (FERROR NIL "~A is illegal DBG-ACCESS-PATH" DBG-ACCESS-PATH)))    
   T)
@@ -85 +85 @@
             (%UNIBUS-WRITE 766110 (COND (DBG-NXM-INHIBIT 4) (T 0))))
     (CHAOS
-      (CHAOS:RETURN-PKT (DBG-CHAOS 'RESET 0 0)))
+     (DBG-CHAOS 'RESET 0 0))
     (OTHERWISE (FERROR NIL "~A is illegal DBG-ACCESS-PATH" DBG-ACCESS-PATH)))
   T)
@@ -144 +144 @@
   (DPB (LOGXOR 1 (CHARACTER-PARITY (LOGAND CHAR 177))) 0701 CHAR))
 
-;;; DBG-CHAOS: Take a unibus cycle over the Chaos net
-;;; First arg is type of cycle (DATA, STATUS, RESET), second is address, third is value
+;;; DBG-CHAOS: Take a debug cycle over the Chaos net
+;;; First arg is type of cycle (DATA, STATUS, RESET, ANALOG, INTERNAL-8748,EXTERNAL-8748)
+;;;  second is address, third is value
 (DEFUN DBG-CHAOS (TYPE ADR &OPTIONAL DATA
                   &AUX PKT (TIMEOUT (COND (DBG-NXM-INHIBIT 4) (T 0))))
@@ -152 +153 @@
          (FORMAT QUERY-IO "~&Chaos host to debug? ")
          (SETQ DBG-HOST (CHAOS:ADDRESS-PARSE (READLINE QUERY-IO)))))
-  (COND ((OR (NULL DBG-UNIQUE-ID) (> DBG-UNIQUE-ID 370))
-         (ASET 2_8. DBG-CHAOS-16 1)             ;0 Unique ID, Reset
-         (CHAOS:RETURN-PKT (CHAOS:SIMPLE DBG-HOST DBG-CHAOS-STRING))
-         (SETQ DBG-UNIQUE-ID 0)))
-  (SETQ DBG-UNIQUE-ID (1+ DBG-UNIQUE-ID))
-  (ASET (+ 2_8. DBG-UNIQUE-ID) DBG-CHAOS-16 1)
+  (COND ((= (ARRAY-LEADER DBG-CHAOS-STRING 0) 2)
+         (COND ((OR (NULL DBG-UNIQUE-ID) (> DBG-UNIQUE-ID 370))
+                (ASET #/$ DBG-CHAOS-STRING 0)
+                (ASET #\SPACE DBG-CHAOS-STRING 1)
+                (ASET 1_8. DBG-CHAOS-16 1)              ;0 Unique ID, Reset
+                (STORE-ARRAY-LEADER 4 DBG-CHAOS-STRING 0)
+                (CHAOS:RETURN-PKT (CHAOS:SIMPLE DBG-HOST DBG-CHAOS-STRING))
+                (STORE-ARRAY-LEADER 2 DBG-CHAOS-STRING 0)
+                (SETQ DBG-UNIQUE-ID 0)))
+         (SETQ DBG-UNIQUE-ID (1+ DBG-UNIQUE-ID))
+         (ASET (+ 1_8. DBG-UNIQUE-ID) DBG-CHAOS-16 1)
+         (ASET #/$ DBG-CHAOS-STRING 0)
+         (ASET #\SPACE DBG-CHAOS-STRING 1)
+         (STORE-ARRAY-LEADER 4 DBG-CHAOS-STRING 0)))
   (SELECTQ TYPE
     (RESET (SETQ TIMEOUT (LOGIOR TIMEOUT DATA))
            (SETQ TYPE 120))
     (DATA (SETQ TYPE (IF DATA 200 000)))
+    (ANALOG (SETQ TYPE 040)                     ; ADR specifies which channel
+            (SETQ ADR (LOGIOR 400 (LSH ADR 1))))
     (STATUS (SETQ TYPE (IF DATA 240 040)
                   ADR 2))
+    (DEBUGGER-HIBERNATE (SETQ TYPE 040)
+                        (SETQ ADR 200))
+    (INTERNAL-8748 (SETQ TYPE (IF DATA 300 100))  ; DATA specifies address
+                   (SETQ ADR (LSH ADR 1)))
+    (EXTERNAL-8748 (SETQ TYPE (IF DATA 340 140))
+                   (SETQ ADR (LSH ADR 1)))
     (OTHERWISE (FERROR NIL "Unknown request type ~S" TYPE)))
-  (ASET (+ (LSH TIMEOUT 8.) TYPE) DBG-CHAOS-16 2)
-  (ASET (LSH ADR -1) DBG-CHAOS-16 3)
-  (AND DATA (ASET (LOGAND DATA 177777) DBG-CHAOS-16 4))
-  (SETQ PKT (CHAOS:SIMPLE DBG-HOST DBG-CHAOS-STRING))
-  (AND (STRINGP PKT)
-       (FERROR NIL "~S" PKT))
-  PKT)
+  (LET ((WORD (AREF DBG-CHAOS-16 1))
+        (PTR))
+    (SETQ PTR (1- (LSH WORD -8.)))
+    (ASET (+ (LSH TYPE 8.) TIMEOUT) DBG-CHAOS-16 (+ 2 (* PTR 3)))
+    (ASET (LSH ADR -1) DBG-CHAOS-16 (+ 3 (* PTR 3)))
+    (AND DATA (ASET (LOGAND DATA 177777) DBG-CHAOS-16 (+ 4 (* PTR 3))))
+    (ASET (DPB (SETQ PTR (+ PTR 2)) 1010 WORD) DBG-CHAOS-16 1)
+    (COND ((OR (> (+ PTR 3) (// CHAOS:MAX-DATA-WORDS-PER-PKT 3))
+               (NOT (BIT-TEST TYPE 200)))
+           ;; Conservative, or a read
+           (STORE-ARRAY-LEADER (+ 4 (* (1- PTR) 6)) DBG-CHAOS-STRING 0)
+           (SETQ PKT (CHAOS:SIMPLE DBG-HOST DBG-CHAOS-STRING))
+           (AND (BIT-TEST TYPE 200) (CHAOS:RETURN-PKT PKT))
+           (STORE-ARRAY-LEADER 2 DBG-CHAOS-STRING 0)
+           PKT))))
 
 (DEFUN DBG-CHAOS-WRITE-FROB ()
-  (ASET 340 DBG-CHAOS-16 2)
+  (ASET 340_8. DBG-CHAOS-16 2)
   (ASET 060 DBG-CHAOS-16 3)
-  (ASET -1 DBG-CHAOS-16 4)
+  (ASET 525252 DBG-CHAOS-16 4)
   (DO () (())
     (ERRSET
@@ -185 +210 @@
       NIL)))
 
+(DEFUN DBG-ANALOG ()
+   (DOLIST (X '(0 1 2 3 4 5 6 7))
+     (DBG-WRITE (LOGIOR 20 X) 0 'EXTERNAL-8748)
+     (DBG-WRITE 30 -1 'EXTERNAL-8748)
+     (PRINT (LDB 0010 (DBG-READ 40 'EXTERNAL-8748)))))
 
 ;;; Higher-level operations

trunk/lisp/lcadr/packed.lisp

@@ -379 +379 @@
 (IF-FOR-LISPM
 (DEFUN DISPLAY-LABEL (LINE)
-  (TV-CLEAR-SCREEN)
-  (CURSORPOS 0 0)
+  (FUNCALL TERMINAL-IO ':CLEAR-SCREEN)
   (FORMAT T "Pack name = ~A.   Check word = ~A.    Version Number = ~D.~%"
           (CONVERT-SYMBOL-TO-STRING-WITHOUT-NULLS PACK-NAME)

trunk/lisp/lcadr/praid.lisp

@@ -171 +171 @@
   (DO () (()) (CC-WRITE-A-MEM ADR N)))
 
+(DEFUN P-A-MEM-R-LOOP (&OPTIONAL (ADR 0))
+  (DO () (()) (CC-READ-A-MEM ADR)))
+
 (defun p-m-rw-a-pass (n &optional (adr 0))
   (CC-WRITE-MD n)               ;PUT VALUE INTO THE MRD REGISTER

trunk/lisp/lcadr/promh.lisp

@@ -361 +361 @@
         ((INTERRUPT-CONTROL) DPB M-ONES         ;CLEAR RESET, SET HALFWORD-MODE,
                 (BYTE-FIELD 1 27.) A-ZERO)      ;AND ENABLE INTERRUPTS
-        ((M-A) DPB M-ONES (BYTE-FIELD 1 22.) A-ZERO)    ;DELAY FOR 1.5 SECONDS FOR MARKSMAN
-RSTDLY  (JUMP-NOT-EQUAL-XCT-NEXT M-A A-ZERO RSTDLY)
-       ((M-A) SUB M-A A-1)
 
 ;;; Set up the map.  First, write a 0 into the first location of the level
@@ -422 +419 @@
 ;;; memory on disk.  Block 1 is allocated to us for this purpose.
 SAVE-A-PAGE
+        ((M-A) DPB M-ONES (BYTE-FIELD 1 18.) A-ZERO)    ;Delay for 0.1 second in case
+SAPDLY  (JUMP-NOT-EQUAL-XCT-NEXT M-A A-ZERO SAPDLY)     ; something random is happening
+       ((M-A) SUB M-A A-1)
         ((M-TEMP-1) A-1)
         (CALL-XCT-NEXT DISK-WRITE)
        ((M-A) SETZ)
+        ((M-TEMP-1) A-1)                                ;Now do a read-compare
+        (CALL-XCT-NEXT DISK-OP-LOW)
+       ((M-TEMP-2) DPB M-ONES (BYTE-FIELD 1 3) A-ZERO)  ;OP 10 = read-compare
+        ((M-TEMP-1) AND READ-MEMORY-DATA A-DISK-ERROR)
+        (JUMP-NOT-EQUAL M-TEMP-1 A-ZERO SAVE-A-PAGE)    ;Got an error on readback, retry
+        (JUMP-IF-BIT-SET (BYTE-FIELD 1 22.) READ-MEMORY-DATA SAVE-A-PAGE)       ;R/C failed
 
 ;;; Read the label (block 0) into physical memory page 0, get disk
@@ -674 +680 @@
 
 DISK-OP
+        (CALL DISK-OP-LOW)
+        ((M-TEMP-1) AND READ-MEMORY-DATA A-DISK-ERROR)
+        (JUMP-NOT-EQUAL M-TEMP-1 A-ZERO ERROR-DISK-ERROR)
+        (POPJ)
+
+DISK-OP-LOW
         ;; Wait for the disk controller to be ready.
         ((VMA-START-READ) A-DISK-REGS)
@@ -718 +730 @@
         (JUMP-IF-BIT-CLEAR (BYTE-FIELD 1 0) READ-MEMORY-DATA DISK-WAIT)
     (ERROR-TABLE AWAIT-DISK-DONE)               ;Hangs near here while waiting for disk
-        ((M-TEMP-1) AND READ-MEMORY-DATA A-DISK-ERROR)
-        (JUMP-NOT-EQUAL M-TEMP-1 A-ZERO ERROR-DISK-ERROR)
         (POPJ)
 

trunk/lisp/lcadr/qf.lisp

@@ -1 @@
-;;; PHONEY -*-LISP-*- MACHINE MICROCODE -- CADR VERSION
-;       ** (c) Copyright 1980 Massachusetts Institute of Technology **
+;;; -*- Mode:Lisp; Package:CADR; Base:8 -*-
+;;; PHONEY LISP MACHINE MICROCODE -- CADR VERSION
+;;;     ** (c) Copyright 1980 Massachusetts Institute of Technology **
 
 ;2/4/79 MODIFIED FOR CHANGES TO MAP-STATUS-CODE IN PAGE MAP 
@@ -14 +15 @@
 (IF-FOR-MACLISP
  (INCLUDE |LMCONS;QFMAC >|) )
-
-;Really wants to be a bignum LSH.  On LISPM, LSH doesnt win for bignums, ASH does.
-; In MACLISP, LSH wins sufficiently.
-(DEFMACRO CC-SHIFT (QUAN AMT)
-  `(#Q ASH #M LSH ,QUAN ,AMT))
 
 ;ALSO SEE FIXNUM DECLARATIONS BELOW WHEN THESE ARE CHANGED.