root/trunk/lisp/lcadr/nldbg.lisp @ 204

;;; Routines for hacking the pseudo-debugger          -*-LISP-*-

;;; The following are the active locations:
;;; 766100  Reads or writes the debuggee-Unibus location addressed by the registers below.
;;; 766114  (Write only) Contains bits 1-16 of the debuggee-Unibus address
;;;         to be accessed.  Bit 0 of the address is always zero.
;;; 766110  (Write only) Contains additional modifier bits, as follows.
;;;         These bits are reset to zero when the debuggee's Unibus is reset.
;;;         1  Bit 17 of the debuggee-Unibus address.
;;;         2  Resets the debuggee's Unibus and bus interface.  Write a 1 here then write a 0.
;;;         4  Timeout inhibit.  This turns off the NXM timeout for all Xbus and Unibus cycles
;;;            done by the debuggee's bus interface (not just those by the debugger).
;;; 766104  (Read only) These contain the status for bus cycles executed on the debuggee's
;;;         busses.  These bits are cleared by writing into location 766044 (Error Status)
;;;         on the debuggee's Unibus.  They are not cleared by power up.
;;;         1  Xbus NXM Error.  Set when an Xbus cycle times out for lack of response.
;;;         2  Xbus Parity Error.  Set when an Xbus read receives a word with bad parity,
;;;            and the Xbus ignore-parity line was not asserted.  Parity Error is also set
;;;            by Xbus NXM Error.
;;;         4  CADR Address Parity Error.  Set when an address received from the processor
;;;            has bad parity.
;;;        10  Unibus NXM Error.  Set when a Unibus cycle times out for lack of response.
;;;        20  CADR Parity Error.  Set when data received from the processor has bad parity.
;;;        40  Unibus Map Error.  Set when an attempt to perform an Xbus cycle through the
;;;            Unibus map is refused because the map specifies invalid or write-protected.
;;;        The remaining bits are random (not necessarily zero).

(DECLARE (SPECIAL DBG-NXM-INHIBIT DBG-ACCESS-PATH DBG-DL11-HIGH-BIT DBG-HOST
                  DBG-CHAOS-STRING DBG-CHAOS-16 DBG-UNIQUE-ID))
(SETQ DBG-NXM-INHIBIT NIL
      DBG-ACCESS-PATH 'BUSINT                   ;Possible values: BUSINT, DL11, CHAOS
      DBG-DL11-HIGH-BIT -1
      DBG-HOST NIL
      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)

;;; Reset the state of the internal variables
(DEFUN DBG-CC-RESET ()
  (SETQ DBG-DL11-HIGH-BIT -1
        DBG-UNIQUE-ID NIL))

;;; Read a location on the debuggee's Unibus
(DEFUN DBG-READ (ADR &OPTIONAL (CHAOS-DBG-TYPE 'DATA))
  (SELECTQ DBG-ACCESS-PATH
    (DL11
      (DBG-UPDATE-HIGH-BIT ADR)
      (FORMAT 'DL11-STREAM "~O" (LSH ADR -1))
      (READ 'DL11-STREAM))
    (BUSINT
      (%UNIBUS-WRITE 766110 (+ (LSH ADR -17.) (COND (DBG-NXM-INHIBIT 4) (T 0))))
      (%UNIBUS-WRITE 766114 (LSH ADR -1))
      (%UNIBUS-READ 766100))
    (CHAOS
      (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 &OPTIONAL (CHAOS-DBG-TYPE 'DATA))
  (SELECTQ DBG-ACCESS-PATH
    (DL11
      (DBG-UPDATE-HIGH-BIT ADR)
      (FORMAT 'DL11-STREAM "~O:~O:" (LSH ADR -1) VAL))
    (BUSINT
      (%UNIBUS-WRITE 766110 (+ (LSH ADR -17.) (COND (DBG-NXM-INHIBIT 4) (T 0))))
      (%UNIBUS-WRITE 766114 (LSH ADR -1))
      (%UNIBUS-WRITE 766100 (LOGAND VAL 177777)))
    (CHAOS
     (DBG-CHAOS CHAOS-DBG-TYPE ADR VAL))
    (OTHERWISE (FERROR NIL "~A is illegal DBG-ACCESS-PATH" DBG-ACCESS-PATH)))    
  T)

;;; Reset the debuggee's Unibus
(DEFUN DBG-RESET ()
  (SETQ CC-UNIBUS-MAP-TO-MD-OK-FLAG NIL)
  (SELECTQ DBG-ACCESS-PATH
    (DL11
      (FORMAT 'DL11-STREAM "2S")
      (FORMAT 'DL11-STREAM "~OS" (+ (ABS DBG-DL11-HIGH-BIT)
                                    (COND (DBG-NXM-INHIBIT 4) (T 0)))))
    (BUSINT (%UNIBUS-WRITE 766110 2)
            (%UNIBUS-WRITE 766110 (COND (DBG-NXM-INHIBIT 4) (T 0))))
    (CHAOS
     (DBG-CHAOS 'RESET 0 0))
    (OTHERWISE (FERROR NIL "~A is illegal DBG-ACCESS-PATH" DBG-ACCESS-PATH)))
  T)

;;; Print the error status bits
(DEFUN DBG-PRINT-STATUS ()
   (CC-PRINT-SET-BITS (SELECTQ DBG-ACCESS-PATH
                        (DL11 (USER:DL11-TYO #/R)
                              (READ 'DL11-STREAM))
                        (BUSINT (%UNIBUS-READ 766104))
                        (CHAOS (LET ((PKT (DBG-CHAOS 'STATUS 0)))
                                 (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)))
                      '(XBUS-NXM-ERR XBUS-PARITY-ERR CADR-ADDRESS-PARITY-ERR
                        UNIBUS-NXM-ERR CADR-DATA-PARITY-ERR UNIBUS-MAP-ERR
                        NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL)))

;;; Reset the error status
(DEFUN DBG-RESET-STATUS ()
  (SELECTQ DBG-ACCESS-PATH
    (DL11)
    (BUSINT (DBG-WRITE 766044 0))
    (CHAOS (DBG-CHAOS 'STATUS 0 0))))

;;; Setup the high bit of the DL11 debugger correctly
(DEFUN DBG-UPDATE-HIGH-BIT (ADR &AUX (HIGH (LDB 2101 ADR)))
  (OR (= HIGH DBG-DL11-HIGH-BIT)
      (FORMAT 'DL11-STREAM "~OS" (+ (SETQ DBG-DL11-HIGH-BIT HIGH)
                                    (COND (DBG-NXM-INHIBIT 4) (T 0))))))

;;; Dummy stream for DL11 I/O
(DEFUN DL11-STREAM (OP &OPTIONAL ARG1)
  (SELECTQ OP
    (:WHICH-OPERATIONS '(TYI TYO))
    (:STRING-OUT (DOTIMES (I (STRING-LENGTH ARG1))
                   (USER:DL11-TYO (CHARACTER-ODD-PARITY (AREF ARG1 I)))))
    (:TYI (DO ((CHAR (USER:DL11-GET-CHAR) (USER:DL11-GET-CHAR)))
              (NIL)
;           (OR (ODDP (CHARACTER-PARITY CHAR))
;               (FERROR NIL "BAD PARITY RECEIVED - ~O" CHAR))
            (SELECTQ (SETQ CHAR (LOGAND CHAR 177))
              (7 (FERROR NIL "ERRORNEOUS COMMAND RECEIVED BY DEBUGGER"))
              (10 (USER:DL11-TYO 33)
                  (FERROR NIL "DEBUGGER GOT PARITY ERROR, RESETTING DEBUGGER"))
              (15)
              (T (RETURN CHAR)))))
    (:TYO (USER:DL11-TYO (CHARACTER-ODD-PARITY ARG1)))))

(DEFUN CHARACTER-PARITY (CHAR &AUX (PARITY 0))
  (DOTIMES (I 8.)
    (SETQ PARITY (LOGXOR CHAR PARITY))
    (SETQ CHAR (LSH CHAR -1)))
  (LOGAND PARITY 1))

(DEFUN CHARACTER-ODD-PARITY (CHAR)
  (DPB (LOGXOR 1 (CHARACTER-PARITY (LOGAND CHAR 177))) 0701 CHAR))

;;; 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))))
  (SETQ TIMEOUT (LOGIOR TIMEOUT (LDB 2101 ADR))) 
  (COND ((NULL DBG-HOST)
         (FORMAT QUERY-IO "~&Chaos host to debug? ")
         (SETQ DBG-HOST (CHAOS:ADDRESS-PARSE (READLINE QUERY-IO)))))
  (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)))
  (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_8. DBG-CHAOS-16 2)
  (ASET 060 DBG-CHAOS-16 3)
  (ASET 525252 DBG-CHAOS-16 4)
  (DO () (())
    (ERRSET
      (PROGN
        (SETQ DBG-UNIQUE-ID (1+ DBG-UNIQUE-ID))
        (ASET (+ 2_8 DBG-UNIQUE-ID) DBG-CHAOS-16 1)
        (CHAOS:RETURN-PKT (CHAOS:SIMPLE DBG-HOST DBG-CHAOS-STRING)))
      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

;;; The Unibus map is 16 words at 766140.  It consists of 14 address bits, write-ok, and valid
;;; It controls locations 140000-177777 (2000 byte locations per page).
(DEFUN DBG-READ-UNIBUS-MAP (LOC)
  (DBG-READ (+ 766140 (* 2 LOC))))

(DEFUN DBG-WRITE-UNIBUS-MAP (LOC VAL)
  (SETQ CC-UNIBUS-MAP-TO-MD-OK-FLAG NIL)        ;Caprine necrophilia
  (DBG-WRITE (+ 766140 (* 2 LOC)) VAL))

;; Returns unibus location mapped into specified xbus location
(DEFUN DBG-SETUP-UNIBUS-MAP (LOC XBUS-LOC)
  (DBG-WRITE-UNIBUS-MAP LOC (+ 140000 (LDB 1016 XBUS-LOC)))
  (+ 140000 (* LOC 2000) (* 4 (LOGAND 377 XBUS-LOC))))

(DEFUN DBG-PRINT-UNIBUS-MAP ()
  (DO ((LOC 0 (1+ LOC))
       (CONTENTS))
      ((= LOC 20))
    (SETQ CONTENTS (DBG-READ-UNIBUS-MAP LOC))
    (PRINT LOC)
    (PRIN1-THEN-SPACE (COND ((ZEROP (LDB 1701 CONTENTS)) 'NOT-VALID) (T 'VALID)))
    (PRIN1-THEN-SPACE (COND ((ZEROP (LDB 1601 CONTENTS)) 'READ-ONLY) (T 'WRITE-OK)))
    (PRIN1 (ASH (LOGAND 37777 CONTENTS) 8))))

;;; Routines to read and write the Xbus using Unibus map location 17

(DEFVAR DBG-UNIBUS-MAP-NUMBER 17)       ;This can be changed by diagnostics

(DEFUN DBG-READ-XBUS (XBUS-LOC)
  (LET ((UBUS-LOC (DBG-SETUP-UNIBUS-MAP DBG-UNIBUS-MAP-NUMBER XBUS-LOC))
        (RES NIL))
    (SETQ RES (DBG-READ UBUS-LOC))
    (LOGDPB (DBG-READ (+ UBUS-LOC 2)) 2020 RES)))

(DEFUN DBG-WRITE-XBUS (XBUS-LOC VAL)
  (LET ((UBUS-LOC (DBG-SETUP-UNIBUS-MAP DBG-UNIBUS-MAP-NUMBER XBUS-LOC)))
    (DBG-WRITE UBUS-LOC (LOGLDB 0020 VAL))
    (DBG-WRITE (+ UBUS-LOC 2) (LDB 2020 VAL))))

;;; Accessing the interrupt-control and so forth registers
;;; 766040  Interrupt control
;;;             1  Disable Interrupt Grant
;;;             2  Local Enable (read only)
;;;          1774  Interrupt Vector of last interrupt
;;;          2000  Enable Unibus Interrupts
;;;          4000  Interrupt Stops Grants
;;;         30000  Interrupt level (0,4,5,6)
;;;         40000  Xbus interrupt (read only)
;;;        100000  Unibus Interrupt
;;;                Only bits masked by 36001 can be written at this address.
;;; 766042  Interrupt control 2 (write only)
;;;                Writes bits masked by 101774 of the above register.
;;; 766044  Error register (writing clears)  (see 764542 above)

(DEFUN DBG-PRINT-INTERRUPT-STATUS ()
  ((LAMBDA (INTC)
      (TERPRI)
      (CC-PRINT-SET-BITS INTC
                         '( DISABLE-INT-GRANT LOCAL-ENABLE NIL NIL NIL NIL NIL NIL NIL NIL
                            ENABLE-UNIBUS-INT INT-STOPS-GRANTS NIL NIL XBUS-INT UNIBUS-INT ))
      (PRINC '| LEVEL=|)
      (PRIN1 (LOGLDB 1402 INTC))
      (PRINC '| VECTOR=|)
      (PRIN1 (LOGAND 1774 INTC)))
   (DBG-READ 766040)))