sys98

Artifact [3a7c8945e8]
Login

Artifact 3a7c8945e82e217a594bbdb50165ee8a7723ba428b5a4eddae0cd8986c3116ae:


;;; FEF Disassembler			-*- Mode:LISP; Package:COMPILER; Base:8 -*-
;	** (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))
  "Print a disassembly of FUNCTION on STANDARD-OUTPUT.
FUNCTION can be a compiled function, an LAMBDA-expression (which will be compiled),
or a function spec (whose definition will be used)."
  (DO ((FUNCTION FUNCTION)) (())
    (COND ((TYPEP FUNCTION ':COMPILED-FUNCTION)
	   (SETQ FEF FUNCTION)
	   (RETURN))
	  ((AND (LISTP FUNCTION)
		(MEMQ (CAR FUNCTION) '(LAMBDA NAMED-LAMBDA SUBST NAMED-SUBST)))
	   (SETQ FEF (COMPILE-LAMBDA FUNCTION (GENSYM)))
	   (RETURN))
	  ((AND (LISTP FUNCTION) (EQ (CAR FUNCTION) 'MACRO))
	   (FORMAT T "~%Definition as macro")
	   (SETQ FUNCTION (CDR FUNCTION)))
	  (T
	   (SETQ FUNCTION (SI:DWIMIFY-PACKAGE FUNCTION))
	   (SETQ FUNCTION (FDEFINITION (SI:UNENCAPSULATE-FUNCTION-SPEC FUNCTION))))))
  (IF (GET-MACRO-ARG-DESC-POINTER FEF)
      (PROGN (SI:DESCRIBE-FEF-ADL FEF) (TERPRI)))
  (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)

(DEFF DISASSEMBLE-INSTRUCTION-LENGTH 'FEF-INSTRUCTION-LENGTH)
(DEFF DISASSEMBLE-FETCH 'FEF-INSTRUCTION)
(DEFF DISASSEMBLE-LIM-PC 'FEF-LIMIT-PC)

(DEFUN DISASSEMBLE-INSTRUCTION (FEF PC &AUX (BASE 8)
			       WD OP SUBOP DEST REG DISP ILEN SECOND-WORD)
  "Print on STANDARD-OUTPUT the disassembly of the instruction at PC in FEF.
Returns the length of that instruction."
  (SETQ ILEN (DISASSEMBLE-INSTRUCTION-LENGTH FEF PC))
  (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)
	  SUBOP (LDB 1503 WD)
	  DEST (LDB 1602 WD)
	  DISP (LDB 0011 WD)
	  REG (LDB 0603 WD))
    (COND ((= ILEN 2)
	   (SETQ PC (1+ PC))
	   (SETQ SECOND-WORD (DISASSEMBLE-FETCH FEF PC))
	   ;; If a two-word insn has a source address, it must be an extended address,
	   ;; so set up REG and DISP to be right for that.
	   (UNLESS (= OP 14)
	     (SETQ REG (LDB 0603 SECOND-WORD)
		   DISP (DPB (LDB 1104 SECOND-WORD)
			     0604 (LDB 0006 SECOND-WORD))))))
    (WHEN (< OP 11) (SETQ OP (LDB 1105 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-RETURN D-LAST)))
	   (DISASSEMBLE-ADDRESS FEF REG DISP SECOND-WORD))
	  ((= OP 11)	    ;ND1
	   (PRINC (NTH SUBOP '(ND1-UNUSED + - * // LOGAND LOGXOR LOGIOR)))
	   (DISASSEMBLE-ADDRESS FEF REG DISP SECOND-WORD))
	  ((= OP 12)	    ;ND2
	   (PRINC (NTH SUBOP '(= > < EQ SETE-CDR SETE-CDDR SETE-1+ SETE-1-)))
	   (DISASSEMBLE-ADDRESS FEF REG DISP SECOND-WORD))
	  ((= OP 13)	    ;ND3
	   (PRINC (NTH SUBOP '(BIND-OBSOLETE? BIND-NIL BIND-POP SET-NIL SET-ZERO PUSH-E MOVEM POP)))
	   (DISASSEMBLE-ADDRESS FEF REG DISP SECOND-WORD))
	  ((= OP 14)	    ;BRANCH
	   (PRINC (NTH SUBOP '(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 SECOND-WORD)
		  (AND (>= DISP 100000) (SETQ DISP (LOGIOR -100000 DISP)))
		  (PRINC "LONG ")
		  (PRIN1 (+ PC DISP 1))
		  (RETURN))))
	  ((= OP 15)	    ;MISC
	   (PRINC "(MISC) ") ;Moon likes to see this
	   (IF (BIT-TEST 1 SUBOP)
	       (SETQ DISP (+ DISP 1000)))
	   (COND ((< DISP 200)
		  (FORMAT T "~A (~D) "
			  (NTH (LDB 0403 DISP)
			       '(AR-1 ARRAY-LEADER %INSTANCE-REF UNUSED-AREFI-3
				 AS-1 STORE-ARRAY-LEADER %INSTANCE-SET UNUSED-AREFI-7))
			  (+ (LDB 0004 DISP)
			     (IF (= (LDB 0402 DISP) 2) 1 0))))
		 ((< DISP 220)
		  (FORMAT T "UNBIND ~D binding~:P " (- DISP 177))  ;code 200 does 1 unbind.
		  (AND (ZEROP DEST) (RETURN)))
		 ((< DISP 240)
		  (FORMAT T "POP-PDL ~D time~:P " (- DISP 220)) ;code 220 does 0 pops.
		  (AND (ZEROP DEST) (RETURN)))
		 ((= DISP 460)  ;(GET 'INTERNAL-FLOOR-1 'QLVAL)
		  (PRINC (NTH (TRUNCATE DEST 2) '(FLOOR CEILING TRUNCATE ROUND)))
		  (PRINC " one value to stack")
		  (SETQ DEST NIL))
		 ((= DISP 510)  ;(GET 'INTERNAL-FLOOR-2 'QLVAL)
		  (PRINC (NTH (TRUNCATE DEST 2) '(FLOOR CEILING TRUNCATE ROUND)))
		  (PRINC " two values to stack")
		  (SETQ DEST NIL))
		 (T
                  (LET ((OP (MICRO-CODE-SYMBOL-NAME-AREA (- DISP 200))))
                    (COND ((NULL OP) (FORMAT T "#~O " DISP))
                          (T (FORMAT T "~A " OP))))))
	   (IF DEST
	       (PRINC (NTH DEST '(D-IGNORE D-PDL D-RETURN D-LAST)))))
	  ((= OP 16)	    ;ND4
	   (SELECTQ SUBOP
	     (0 (FORMAT T "STACK-CLOSURE-DISCONNECT  local slot ~D" DISP))
	     (1 (LET ((LOCALNUM
			(LDB 0012
			     (NTH DISP
				  (%P-CONTENTS-OFFSET
				    FEF (- (%P-LDB %%FEFH-PC-IN-WORDS FEF) 2))))))
		  (FORMAT T "STACK-CLOSURE-UNSHARE LOCAL|~D" LOCALNUM)
		  (LET ((TEM (DISASSEMBLE-LOCAL-NAME FEF LOCALNUM)))
		    (AND TEM (FORMAT T " ~30,8T;~A" TEM)))))
	     (2 (FORMAT T "MAKE-STACK-CLOSURE  local slot ~D" DISP))
	     (3 (FORMAT T "PUSH-NUMBER ~S" DISP))
	     (4 (FORMAT T "STACK-CLOSURE-DISCONNECT-FIRST  local slot ~D" DISP))
	     (5 (FORMAT T "PUSH-CDR-IF-CAR-EQUAL ")
		(DISASSEMBLE-ADDRESS FEF REG DISP SECOND-WORD PC))
	     (6 (FORMAT T "PUSH-CDR-STORE-CAR-IF-CONS ")
		(DISASSEMBLE-ADDRESS FEF REG DISP SECOND-WORD PC))
	     (T (FORMAT T "UNDEF-ND4-~D ~D" SUBOP DISP))))
	  ((= OP 20)
	   (FORMAT T "~A (~D) "
		   (NTH REG
			'(AR-1 ARRAY-LEADER %INSTANCE-REF COMMON-LISP-AR-1
			  SET-AR-1 SET-ARRAY-LEADER SET-%INSTANCE-REF UNUSED-AREFI))
		   (+ (LDB 0006 DISP)
		      (IF (MEMQ REG '(2 6)) 1 0)))
	   (PRINC (NTH DEST '(D-IGNORE D-PDL D-RETURN D-LAST))))
	  (T		    ;UNDEF
	   (PRINC 'UNDEF-)
	   (PRIN1 OP))))
  ILEN)

;This ought to figure out which flavor's mapping table is going to be current
;at a certain PC, assuming that the compiled code explicitly sets it up.
(DEFUN DISASSEMBLE-CURRENT-FLAVOR (FEF PC)
  FEF PC
  NIL)

(DEFUN DISASSEMBLE-ADDRESS (FEF REG DISP &OPTIONAL SECOND-WORD PC
			    &AUX TEM)
  "Print out the disassembly of an instruction source address.
REG is the register number of the address, and DISP is the displacement.
SECOND-WORD should be the instruction's second word if it has two.
PC should be where the instruction was found in the FEF."
  (TYO 40)
  ;; In a one-word instruction, the displacement for types 4 thru 7 is only 6 bits,
  ;; so ignore the rest.  In a two word insn, we have been fed the full disp from word 2.
  (IF (AND (>= REG 4) (NOT SECOND-WORD))
      (SETQ DISP (LOGAND 77 DISP)))
  (COND ((< REG 4)
         (FORMAT T "FEF|~D ~30,8T;" DISP)
	 (DISASSEMBLE-POINTER FEF DISP PC))
	((= REG 4)
	 (PRINC '/')
	 (PRIN1 (CONSTANTS-AREA DISP)))
        ((= REG 5)
         (FORMAT T "LOCAL|~D" DISP)
         (SETQ TEM (DISASSEMBLE-LOCAL-NAME FEF DISP))
         (AND TEM (FORMAT T " ~30,8T;~A" TEM)))
        ((= REG 6)
         (FORMAT T "ARG|~D" DISP)
         (SETQ TEM (DISASSEMBLE-ARG-NAME FEF DISP))
         (AND TEM (FORMAT T " ~30,8T;~A" TEM)))
	((AND (NOT SECOND-WORD) (= DISP 77))
	 (PRINC 'PDL-POP))
	((< DISP 40)
         (FORMAT T "SELF|~D" DISP)
         (SETQ TEM (DISASSEMBLE-INSTANCE-VAR-NAME FEF DISP))
         (AND TEM (FORMAT T " ~30,8T;~A" TEM)))
	((< DISP 70)
         (FORMAT T "SELF-MAP|~D" (- DISP 40))
         (SETQ TEM (DISASSEMBLE-MAPPED-INSTANCE-VAR-NAME FEF (- DISP 40)))
         (AND TEM (FORMAT T " ~30,8T;~A" TEM)))
	(T (FORMAT T "PDL|~D (undefined)" DISP))))

(DEFUN DISASSEMBLE-POINTER (FEF DISP PC &AUX CELL LOC PTR OFFSET TEM)
  (SETQ LOC (%MAKE-POINTER-OFFSET DTP-LOCATIVE FEF DISP))
  (COND ((= (%P-LDB-OFFSET %%Q-DATA-TYPE FEF DISP) DTP-SELF-REF-POINTER)
	 (MULTIPLE-VALUE-BIND (PTR COMPONENT-FLAVOR-FLAG)
	     (SI:FLAVOR-DECODE-SELF-REF-POINTER 
	       (OR (DISASSEMBLE-CURRENT-FLAVOR FEF PC)
		   (SI:FEF-FLAVOR-NAME FEF))
	       (%P-LDB-OFFSET %%Q-POINTER FEF DISP))
	   (IF (NULL PTR)
	       (SETQ CELL "self-ref-pointer " PTR (%P-LDB-OFFSET %%Q-POINTER FEF DISP))
	     (SETQ CELL (IF COMPONENT-FLAVOR-FLAG "mapping table for " ""))
	     (IF DISASSEMBLE-OBJECT-OUTPUT-FUN
		 (FUNCALL DISASSEMBLE-OBJECT-OUTPUT-FUN PTR CELL LOC T)
	       (PRINC CELL)
	       (PRIN1 PTR)
	       (IF (EQUAL CELL "")
		   (PRINC " in SELF"))))))
	((= (%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 "))))
	       ((CONSP PTR)
		(SETQ PTR (CAR PTR) CELL "#'"))
	       (T (SETQ CELL "")))
	 (IF DISASSEMBLE-OBJECT-OUTPUT-FUN
	     (FUNCALL DISASSEMBLE-OBJECT-OUTPUT-FUN PTR CELL LOC T)
	   (PRINC CELL)
	   (PRIN1 PTR) ))
	(T
	 (IF DISASSEMBLE-OBJECT-OUTPUT-FUN
	     (FUNCALL DISASSEMBLE-OBJECT-OUTPUT-FUN (CAR LOC) "'" LOC NIL)
	   (PRINC '/')
	   (PRIN1 (%P-CONTENTS-OFFSET FEF DISP))))))

;Given a fef and an instance variable slot number,
;find the name of the instance variable,
;if the fef knows which flavor is involved.
(DEFUN DISASSEMBLE-INSTANCE-VAR-NAME (FEF SLOTNUM)
  (LET ((FLAVOR (GET (CADR (ASSQ ':FLAVOR (SI:FUNCTION-DEBUGGING-INFO FEF))) 'SI:FLAVOR)))
    (AND FLAVOR (NTH SLOTNUM (SI:FLAVOR-ALL-INSTANCE-VARIABLES FLAVOR)))))

(DEFUN DISASSEMBLE-MAPPED-INSTANCE-VAR-NAME (FEF MAPSLOTNUM)
  (LET ((FLAVOR (GET (CADR (ASSQ ':FLAVOR (SI:FUNCTION-DEBUGGING-INFO FEF))) 'SI:FLAVOR)))
    (AND FLAVOR (NTH MAPSLOTNUM (SI:FLAVOR-MAPPED-INSTANCE-VARIABLES FLAVOR)))))

;; 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))))))))