;;; FEF Disassembler			-*-LISP-*-
;	** (c) Copyright 1980 Massachusetts Institute of Technology **
;;; This stuff is used by LISPM2; EH >.  If you change things around,
;;; make sure not to break that program.

(DEFVAR DISASSEMBLE-OBJECT-OUTPUT-FUN NIL)
(DEFUN DISASSEMBLE (FUNCTION &AUX FEF LIM-PC ILEN (DISASSEMBLE-OBJECT-OUTPUT-FUN NIL))
  
  (COND ((= (%DATA-TYPE FUNCTION) DTP-FEF-POINTER)
	 (SETQ FEF FUNCTION))
        ((SETQ FEF (FDEFINITION (SI:UNENCAPSULATE-FUNCTION-SPEC FUNCTION)))))
  (COND ((AND (LISTP FEF)
	      (EQ (CAR FEF) 'MACRO))
	 (FORMAT T "~%Definition as macro")
	 (SETQ FEF (CDR FEF))))
  (OR (= (%DATA-TYPE FEF) DTP-FEF-POINTER)
      (FERROR NIL "Can't find FEF for ~S" FUNCTION))
  (SETQ LIM-PC (DISASSEMBLE-LIM-PC FEF))
  (DO PC (FEF-INITIAL-PC FEF) (+ PC ILEN) (>= PC LIM-PC)
    (TERPRI)
    (SETQ ILEN (DISASSEMBLE-INSTRUCTION FEF PC)))
  (TERPRI)
  FUNCTION)

(DEFUN DISASSEMBLE-LIM-PC (FEF &AUX LIM-PC)
  (SETQ LIM-PC (* 2 (SI:FEF-LENGTH FEF)))
  (COND ((ZEROP (DISASSEMBLE-FETCH FEF (1- LIM-PC)))
	 (1- LIM-PC))
	(T LIM-PC)))

;; Return the length of the instruction in FEF at PC.
(defun disassemble-instruction-length (fef pc &aux wd op disp)
    (setq wd (disassemble-fetch fef pc))
    (setq op (ldb 1104 wd)
	  disp (ldb 0011 wd))
    (cond ((and (= op 14) (= disp 777)) 2)
	  (t 1)))

;Returns the length of the instruction, usually 1. 
(DEFUN DISASSEMBLE-INSTRUCTION (FEF PC &AUX &SPECIAL (BASE 8) &LOCAL
			       WD OP DEST REG DISP)
  (PROG NIL  ;PROG so that RETURN can be used to return unusual instruction lengths. 
    (SETQ WD (DISASSEMBLE-FETCH FEF PC))
    (PRIN1 PC)
    (TYO 40)
    (SETQ OP (LDB 1104 WD)
	  DEST (LDB 1503 WD)
	  DISP (LDB 0011 WD)
	  REG (LDB 0603 WD))
    (COND ((ZEROP WD)
	   (PRINC "0"))
	  ((< OP 11)     ;DEST/ADDR 
	   (PRINC (NTH OP '(CALL CALL0 MOVE CAR CDR CADR CDDR CDAR CAAR)))
	   (TYO 40)
	   (PRINC (NTH DEST '(D-IGNORE D-PDL D-NEXT D-LAST
			      D-RETURN D-NEXT-Q D-LAST-Q D-NEXT-LIST)))
	   (DISASSEMBLE-ADDRESS FEF REG DISP))
	  ((= OP 11)	    ;ND1
	   (PRINC (NTH DEST '(ND1-UNUSED + - * // LOGAND LOGXOR LOGIOR)))
	   (DISASSEMBLE-ADDRESS FEF REG DISP))
	  ((= OP 12)	    ;ND2
	   (PRINC (NTH DEST '(= > < EQ SETE-CDR SETE-CDDR SETE-1+ SETE-1-)))
	   (DISASSEMBLE-ADDRESS FEF REG DISP))
	  ((= OP 13)	    ;ND3
	   (PRINC (NTH DEST '(BIND-OBSOLETE? BIND-NIL BIND-POP SET-NIL SET-ZERO PUSH-E MOVEM POP)))
	   (DISASSEMBLE-ADDRESS FEF REG DISP))
	  ((= OP 14)	    ;BRANCH
	   (PRINC (NTH DEST '(BR BR-NIL BR-NOT-NIL BR-NIL-POP
			      BR-NOT-NIL-POP BR-ATOM BR-NOT-ATOM BR-ILL-7)))
	   (TYO 40)
	   (AND (> DISP 400) (SETQ DISP (LOGIOR -400 DISP))) ;SIGN-EXTEND
	   (COND ((NEQ DISP -1)	    ;ONE WORD
		  (PRIN1 (+ PC DISP 1)))
		 (T	    ;LONG BRANCH
		  (SETQ DISP (DISASSEMBLE-FETCH FEF (SETQ PC (1+ PC))))
		  (AND (> DISP 100000) (SETQ DISP (LOGIOR -100000 DISP)))
		  (PRINC "*")	;INDICATE LONG BRANCH FOR USER.
		  (PRIN1 (+ PC DISP 1))
		  (RETURN 2))))
	  ((= OP 15)	    ;MISC
	   (PRINC "(MISC) ") ;Moon likes to see this
	   (COND ((< DISP 100) (FORMAT T "LIST ~D long " DISP))
		 ((< DISP 200) (FORMAT T "LIST-IN-AREA ~D long " (- DISP 100)))
		 ((< DISP 220)
		  (FORMAT T "UNBIND ~D binding~:P " (- DISP 177))  ;code 200 does 1 unbind.
		  (AND (ZEROP DEST) (RETURN 1)))
		 ((< DISP 240)
		  (FORMAT T "POP-PDL ~D time~:P " (- DISP 220)) ;code 220 does 0 pops.
		  (AND (ZEROP DEST) (RETURN 1)))
		 (T
                  (LET ((OP (MICRO-CODE-SYMBOL-NAME-AREA (- DISP 200))))
                    (COND ((NULL OP) (FORMAT T "#~O " DISP))
                          (T (FORMAT T "~A " OP))))))
	   (PRINC (NTH DEST '(D-IGNORE D-PDL D-NEXT D-LAST
			      D-RETURN D-NEXT-Q D-LAST-Q D-NEXT-LIST))))
	  (T		    ;UNDEF
	   (PRINC 'UNDEF-)
	   (PRIN1 OP)))
    (RETURN 1)))

;; Print out the disassembly of an instruction source address.
;; REG is the register number of the address, and DISP is the displacement.
(DEFUN DISASSEMBLE-ADDRESS (FEF REG DISP &AUX PTR OFFSET TEM LOC CELL)
  (TYO 40)
  (COND ((< REG 4)
	 (SETQ LOC (%MAKE-POINTER-OFFSET DTP-LOCATIVE FEF DISP))
         (FORMAT T "FEF|~D ~30,8T;" DISP)
	 (COND ((= (%P-LDB-OFFSET %%Q-DATA-TYPE FEF DISP) DTP-EXTERNAL-VALUE-CELL-POINTER)
		(SETQ PTR (%FIND-STRUCTURE-HEADER
			   (SETQ TEM (%P-CONTENTS-AS-LOCATIVE-OFFSET FEF DISP)))
		      OFFSET (%POINTER-DIFFERENCE TEM PTR))
		(COND ((SYMBOLP PTR)
		       (SETQ CELL (NTH OFFSET '("@+0?? " "" "#'"
						"@PLIST-HEAD-CELL " "@PACKAGE-CELL "))))
		      ((LISTP PTR)
		       (SETQ PTR (SI:METH-FUNCTION-SPEC PTR) CELL "#'"))
		      (T (SETQ CELL "")))
		(IF DISASSEMBLE-OBJECT-OUTPUT-FUN
		    (FUNCALL DISASSEMBLE-OBJECT-OUTPUT-FUN PTR CELL LOC)
		    (PRINC CELL)
		    (PRIN1 PTR) ))
	       (T
		(IF DISASSEMBLE-OBJECT-OUTPUT-FUN
		    (FUNCALL DISASSEMBLE-OBJECT-OUTPUT-FUN (CAR LOC) "'" LOC)
		    (PRINC '/')
		    (PRIN1 (%P-CONTENTS-OFFSET FEF DISP))))))
	((= REG 4)
	 (PRINC '/')
	 (PRIN1 (CONSTANTS-AREA (LOGAND 77 DISP))))
	((= DISP 777)
	 (PRINC 'PDL-POP))
        ((= REG 5)
         (FORMAT T "LOCAL|~D" (LOGAND 77 DISP))
         (SETQ TEM (DISASSEMBLE-LOCAL-NAME FEF (LOGAND 77 DISP)))
         (AND TEM (FORMAT T " ~30,8T;~A" TEM)))
        ((= REG 6)
         (FORMAT T "ARG|~D" (LOGAND 77 DISP))
         (SETQ TEM (DISASSEMBLE-ARG-NAME FEF (LOGAND 77 DISP)))
         (AND TEM (FORMAT T " ~30,8T;~A" TEM)))
	(T
         (FORMAT T "PDL|-~D" (LOGAND 77 DISP)))))

;; Given a fef and the number of a slot in the local block,
;; return the name of that local (or NIL if unknown).
;; If it has more than one name due to slot-sharing, we return a list of
;; the names, but if there is only one name we return it.
(DEFUN DISASSEMBLE-LOCAL-NAME (FEF LOCALNUM)
  (LET ((FDI (SI:FUNCTION-DEBUGGING-INFO FEF)))
    (LET ((NAMES (NTH LOCALNUM (CADR (ASSQ 'COMPILER:LOCAL-MAP FDI)))))
      (COND ((NULL NAMES) NIL)
	    ((NULL (CDR NAMES)) (CAR NAMES))
	    (T NAMES)))))

;; Given a fef and the number of a slot in the argument block,
;; return the name of that argument (or NIL if unknown).
;; First we look for an arg map, then we look for a name in the ADL.
(DEFUN DISASSEMBLE-ARG-NAME (FEF ARGNUM &AUX
                                 (FDI (SI:FUNCTION-DEBUGGING-INFO FEF))
                                 (ARGMAP (CADR (ASSQ 'COMPILER:ARG-MAP FDI))))
    (COND (ARGMAP (CAR (NTH ARGNUM ARGMAP)))
          (T (DO ((ADL (GET-MACRO-ARG-DESC-POINTER FEF) (CDR ADL))
                  (IDX 0 (1+ IDX))
                  (ADLWORD))
                 ((NULL ADL))
               (SETQ ADLWORD (CAR ADL))
               (SELECT (MASK-FIELD %%FEF-ARG-SYNTAX ADLWORD)
                 ((FEF-ARG-REQ FEF-ARG-OPT))
                 (OTHERWISE (RETURN)))
               (AND (= 1 (LDB %%FEF-NAME-PRESENT ADLWORD))
                    (SETQ ADL (CDR ADL)))
               (COND ((= IDX ARGNUM)
                      (RETURN (AND (= 1 (LDB %%FEF-NAME-PRESENT ADLWORD)) (CAR ADL)))))
               (SELECT (MASK-FIELD %%FEF-INIT-OPTION ADLWORD)
                 ((FEF-INI-PNTR FEF-INI-C-PNTR FEF-INI-OPT-SA FEF-INI-EFF-ADR)
                  (SETQ ADL (CDR ADL))))))))

;; Given a FEF and a PC, returns the corresponding 16-bit macro instruction.
;; There is no error checking.
(DEFUN DISASSEMBLE-FETCH (FEF PC &AUX IDX)
  (SETQ IDX (// PC 2))
  (COND ((ZEROP (LOGAND 1 PC))
	 (%P-LDB-OFFSET %%Q-LOW-HALF FEF IDX))
	((%P-LDB-OFFSET %%Q-HIGH-HALF FEF IDX))))