;;; -*- Mode:Common-Lisp; Package:SI; Base:10 -*-

;; 			      RESTRICTED RIGHTS LEGEND
;; 
;; Use, duplication, or disclosure by the Government is subject to
;; restrictions as set forth in subdivision (c)(1)(ii) of the Rights in
;; Technical Data and Computer Software clause at 252.227-7013.
;; 
;; 			TEXAS INSTRUMENTS INCORPORATED.
;; 				 P.O. BOX 149149
;; 			      AUSTIN, TEXAS 78714-9149
;; 				    MS 2151
;; 
;;  Copyright (C) 1987,1988,1989,1990 Texas Instruments Incorporated. All rights reserved.

;;;   *-----------------------------------------------------------*
;;;   |			   Tree Inverter			  |
;;;   *-----------------------------------------------------------*

;; 10/27/87 HRC - Original version.
;; 11/24/87 DNG - Some cleanup.
;; 12/02/87 DNG - More cleanup.
;; 12/03/87 DNG - Convert bignum address arguments to negative fixnums.
;; 12/04/87 DNG - Don't stop on a symbol which is in TARGET-OBJECT-LIST .
;; 12/09/87 DNG - Disregard pointer from symbol to its package.
;; 12/11/87 DNG - Clear TOP-LEVEL-FORM to avoid finding references in the argument list.
;; 12/18/87 DNG - Introduce structure B-TREE to make the code easier to understand.
;;		Show where an object was found in a vector, symbol, or instance.
;; 12/23/87 DNG - Error if memory addresses are given that will become invalid 
;;		when train space is cleared.  Permit CTRL-ABORT in cold band.
;;  1/07/88 DNG - Improve output format.
;;  1/08/88 DNG - Don't take an uninterned symbol to be a root.  Add reporting 
;;		for reference paths rooted in static regions.
;;  1/19/88 DNG - Add some debug printout.  Introduce new variable 
;;		PACKAGE-ARRAYS for more efficient way of ignoring pointers from packages 
;;		to symbols.
;;  2/09/88 DNG - Use SIZE-OF-REGION-ARRAYS instead of 2048.  Allow turning 
;;		off dynamic training automatically and continuing.  Erase Xref table.
;;  2/10/88 DNG - Allow CTRL-ABORT in ENTER-NEW-RANGE; adjust indentation.

(EXPORT 'INVERT-TREE)

(PROCLAIM '(INLINE SEARCH-TREE-TO-BUILD-HISTORY SEARCH-FOR-GREATER-THAN-OR-EQUAL))

;;
;;  BINARY SEARCH AND INSERT PACKAGE
;;
(DEFCONSTANT MAX-COUNT (- (BYTE-SIZE %%Q-POINTER) 1)) ; maximum depth of the tree

(DEFSTRUCT (B-TREE (:ALTERANT NIL) (:PREDICATE NIL) (:COPIER NIL))
  SEARCH-VALUE
  (LEFT-LINK NIL)
  (RIGHT-LINK NIL)
  COUNT
  OBJECT)

;; Search History Table
(DEFSUBST HISTORY-F (ARRAY INDEX)
  "Direction of link from previous entry: 0 for right, 1 for left."
  (AREF ARRAY INDEX 0)) 
(DEFSUBST HISTORY-V (ARRAY INDEX)
  "Location of an entry."
  (AREF ARRAY INDEX 1))
(DEFSUBST RIGHTP (F-VALUE)
  "Right link taken?"
  (ZEROP F-VALUE))

(DEFUN CREATE-TREE ()
  (LET* ((HISTORY (MAKE-ARRAY (LIST MAX-COUNT 2)))
	 (LOW-COUNT-RECORD (MAKE-B-TREE :SEARCH-VALUE NIL :COUNT 0 :OBJECT NIL))
	 (TREE (MAKE-B-TREE :SEARCH-VALUE NIL :RIGHT-LINK LOW-COUNT-RECORD
			    :COUNT MAX-COUNT :OBJECT HISTORY)))
    ;; F1=0, WE ALWAYS START THE SEARCH WITH THE RIGHT LINK OF HIGH COUNT
    (SETF (HISTORY-F HISTORY 1) 0)
    ;; V0=HIGH COUNT
    (SETF (HISTORY-V HISTORY 0) TREE)
    ;; SAVE A POINTER TO THE LOW COUNT RECORD IN THE F0 SLOT
    (SETF (HISTORY-F HISTORY 0) LOW-COUNT-RECORD)
    TREE))


(DEFUN SEARCH-TREE-TO-BUILD-HISTORY (SEARCH-VALUE TREE)
  (DO ((NODE-POINTER (B-TREE-RIGHT-LINK TREE))
       (STACK-POINTER (%MAKE-POINTER-OFFSET DTP-FIX (B-TREE-OBJECT TREE) 5.)
		      (%MAKE-POINTER-OFFSET DTP-FIX STACK-POINTER 2.)))
      ((= 0 (B-TREE-COUNT NODE-POINTER))
       (LSH (- (%POINTER-DIFFERENCE STACK-POINTER (B-TREE-OBJECT TREE)) 3.) -1.))
    (WHEN (= SEARCH-VALUE (B-TREE-SEARCH-VALUE NODE-POINTER))
      (RETURN-FROM SEARCH-TREE-TO-BUILD-HISTORY NODE-POINTER))
    (%P-STORE-CONTENTS STACK-POINTER NODE-POINTER)
    (COND ((< SEARCH-VALUE (B-TREE-SEARCH-VALUE NODE-POINTER))
	   (SETF NODE-POINTER (B-TREE-LEFT-LINK NODE-POINTER))
	   (%P-STORE-CONTENTS-OFFSET 1. STACK-POINTER 1.))
	  (T (SETF NODE-POINTER (B-TREE-RIGHT-LINK NODE-POINTER))
	     (%P-STORE-CONTENTS-OFFSET 0. STACK-POINTER 1.)))))


(DEFUN SEARCH-FOR-EQUAL (SEARCH-VALUE TREE)
  (DO ((NODE-POINTER (B-TREE-RIGHT-LINK TREE))
       (FIND NIL))
      ((OR (= 0 (B-TREE-COUNT NODE-POINTER)) FIND)
       FIND)
    (COND ((= SEARCH-VALUE (B-TREE-SEARCH-VALUE NODE-POINTER))
	   (SETF FIND (B-TREE-OBJECT NODE-POINTER)))
	  ((< SEARCH-VALUE (B-TREE-SEARCH-VALUE NODE-POINTER))
	   (SETF NODE-POINTER (B-TREE-LEFT-LINK NODE-POINTER)))
	  (T (SETF NODE-POINTER (B-TREE-RIGHT-LINK NODE-POINTER))))))

(DEFUN SEARCH-FOR-LESS-THAN-OR-EQUAL (SEARCH-VALUE TREE)
  (LET ((K (SEARCH-TREE-TO-BUILD-HISTORY SEARCH-VALUE TREE)))
    (IF (NOT (NUMBERP K))
	(B-TREE-OBJECT K) ;;EXIT IF AN EQUAL WAS FOUND
      (DO ((I K (1- I))
	   (HISTORY (B-TREE-OBJECT TREE))
	   (LESS NIL))
	  ((OR LESS (= I 1))
	   (IF LESS (B-TREE-OBJECT LESS) NIL))
	(WHEN (RIGHTP (HISTORY-F HISTORY I))
	  (SETF LESS (HISTORY-V HISTORY (1- I))))))))

(DEFUN SEARCH-FOR-GREATER-THAN-OR-EQUAL (SEARCH-VALUE TREE)
  (LET ((K (SEARCH-TREE-TO-BUILD-HISTORY SEARCH-VALUE TREE)))
    (IF (NOT (NUMBERP K))
	(B-TREE-OBJECT K) ;; EXIT IF AN EQUAL WAS FOUND
      (DO ((STACK-POINTER (%MAKE-POINTER-OFFSET DTP-FIX (B-TREE-OBJECT TREE)
						(+ (LSH K 1.) 2.))
			  (%MAKE-POINTER-OFFSET DTP-FIX STACK-POINTER -2.))
	   (STACK-LIMIT (%MAKE-POINTER-OFFSET DTP-FIX (B-TREE-OBJECT TREE) 4.)))
	  ((= STACK-POINTER STACK-LIMIT) NIL)
	(WHEN (= 1 (%P-POINTER STACK-POINTER))
	  (RETURN-FROM SEARCH-FOR-GREATER-THAN-OR-EQUAL
	    (B-TREE-OBJECT (%MAKE-POINTER (%DATA-TYPE TREE)
					  (%P-POINTER-OFFSET STACK-POINTER -1.)))))))))

(DEFUN INSERT-TREE (SEARCH-VALUE CV TREE)
  (LET ((K (SEARCH-TREE-TO-BUILD-HISTORY SEARCH-VALUE TREE)))
    (IF (NOT (NUMBERP K))
	NIL
      (LET* ((HISTORY (B-TREE-OBJECT TREE))
	     (FK (HISTORY-F HISTORY K))
	     (VK-1 (HISTORY-V HISTORY (1- K)))
	     (NEW-NODE (MAKE-B-TREE :SEARCH-VALUE SEARCH-VALUE
				    :LEFT-LINK (HISTORY-F HISTORY 0) ; POINTER TO LOW COUNT
				    :RIGHT-LINK (HISTORY-F HISTORY 0)
				    :COUNT 1
				    :OBJECT CV)))
	(IF (RIGHTP FK)				; HOOK NEW NODE TO SAME LINK OF VK-1
	    (SETF (B-TREE-RIGHT-LINK VK-1) NEW-NODE)
	  (SETF (B-TREE-LEFT-LINK VK-1) NEW-NODE))
	(SETF (HISTORY-V HISTORY K) NEW-NODE)	; REPLACE LOW COUNT WITH NEW NODE
	(DO ((EXIT NIL)
	     (VK (HISTORY-V HISTORY K) (HISTORY-V HISTORY K))
	     (VK-1 (HISTORY-V HISTORY (1- K)) (HISTORY-V HISTORY (1- K)))
	     (FK-1 (HISTORY-F HISTORY (1- K)) (HISTORY-F HISTORY (1- K)))
	     (VK-2) (VK-3) (FK-2))
	    (EXIT T)
	  (COND ((< K 3) (WHEN (>= (B-TREE-COUNT VK) (B-TREE-COUNT VK-1))
			   (SETF (B-TREE-COUNT VK-1) (1+ (B-TREE-COUNT VK-1))))
			 (SETF EXIT T))
		;; CHECK FOR UNBALANCED TREE
		((<= (B-TREE-COUNT VK)
		     (PROGN (SETF VK-2 (HISTORY-V HISTORY (- K 2)))
			    (B-TREE-COUNT (IF (RIGHTP FK-1)
					      (B-TREE-LEFT-LINK VK-2)
					    (B-TREE-RIGHT-LINK VK-2)))))
		 ;; HERE UNBALANCE HAS NOT BEEN DETECTED (YET)
		 (COND ((< (B-TREE-COUNT VK) (B-TREE-COUNT VK-1)) (SETF EXIT T))
		       (T (SETF (B-TREE-COUNT VK-1) (1+ (B-TREE-COUNT VK-1)))
			  (SETF K (1- K)))))
						; HERE THE TREE IS UNBALANCED
		(T (SETF FK (HISTORY-F HISTORY K))
		   (SETF FK-2 (HISTORY-F HISTORY (- K 2)))
		   (SETF VK-3 (HISTORY-V HISTORY (- K 3)))
		   (COND ((= FK FK-1)
			  ;; CLASS 1 OF UNBALANCE
			  (IF (RIGHTP FK)
			      (PSETF (B-TREE-LEFT-LINK VK-1) VK-2
				     (B-TREE-RIGHT-LINK VK-2) (B-TREE-LEFT-LINK VK-1))
			    (PSETF (B-TREE-RIGHT-LINK VK-1) VK-2
				   (B-TREE-LEFT-LINK VK-2) (B-TREE-RIGHT-LINK VK-1)))
			  (IF (RIGHTP FK-2)
			      (SETF (B-TREE-RIGHT-LINK VK-3) VK-1)
			    (SETF (B-TREE-LEFT-LINK VK-3) VK-1))
			  (INCF (B-TREE-COUNT VK-1) 1)
			  (DECF (B-TREE-COUNT VK-2) 1)
			  (SETF EXIT T))
			 ;; CLASS 2 OF UNBALANCE
			 (T (IF (RIGHTP FK)
				(PSETF (B-TREE-LEFT-LINK VK) VK-1
				       (B-TREE-RIGHT-LINK VK-1) (B-TREE-LEFT-LINK VK)
				       (B-TREE-RIGHT-LINK VK) VK-2
				       (B-TREE-LEFT-LINK VK-2) (B-TREE-RIGHT-LINK VK))
			      (PSETF (B-TREE-RIGHT-LINK VK) VK-1
				     (B-TREE-LEFT-LINK VK-1) (B-TREE-RIGHT-LINK VK)
				     (B-TREE-LEFT-LINK VK) VK-2
				     (B-TREE-RIGHT-LINK VK-2) (B-TREE-LEFT-LINK VK)) )
			    (IF (RIGHTP FK-2)
				(SETF (B-TREE-RIGHT-LINK VK-3) VK)
			      (SETF (B-TREE-LEFT-LINK VK-3) VK))
			    (INCF (B-TREE-COUNT VK) 1)
			    (DECF (B-TREE-COUNT VK-2) 1)
			    (SETF EXIT T))))))))))


(DEFVAR LIST-OF-RANGES)
(DEFVAR NUMBER-OF-RANGES)
(DEFVAR NO-INTEREST-LIST)
(DEFVAR INITIAL-REGION-FREE-POINTER)
(DEFVAR HIT-FLAG NIL)
(DEFVAR SYMBOL-LIST)
(DEFVAR PACKAGE-ARRAYS) ; list of package symbol table arrays

(PROCLAIM '(TYPE B-TREE LIST-OF-RANGES NO-INTEREST-LIST))
(PROCLAIM '(TYPE INTEGER NUMBER-OF-RANGES))
(PROCLAIM '(TYPE LIST SYMBOL-LIST PACKAGE-ARRAYS))
(PROCLAIM '(TYPE VECTOR INITIAL-REGION-FREE-POINTER))

(DEFVAR TARGET-OBJECT-LIST)

(DEFVAR *VERBOSE* NIL)

(DEFUN MAYBE-ABORT-NOW ()
  ;; enable aborting in cold band, which does not support CTRL-ABORT
  (WHEN (AND (LISTEN *TERMINAL-IO*) 
	     (EQL (READ-CHAR *TERMINAL-IO*) #\CTRL-ABORT))
    (FORMAT T "[abort]")
    (SIGNAL 'SYS:ABORT "Abort."))
  (VALUES))

(DEFUN ENTER-NEW-RANGE (ADDR &AUX MIN MAX LIST)
  (INSERT-TREE ADDR  ADDR NO-INTEREST-LIST)
  (SETF MIN (%MAKE-POINTER DTP-FIX (%FIND-STRUCTURE-LEADER ADDR)))
  (COND ((SETF LIST (= (LDB %%REGION-REPRESENTATION-TYPE
			    (REGION-BITS (%REGION-NUMBER ADDR)))
		       %REGION-REPRESENTATION-TYPE-LIST))
	 (SETF MAX ADDR))
	(T
	 (SETF MAX (1- (+ MIN (%STRUCTURE-TOTAL-SIZE MIN))))))
  (LET ((OBJECT (%FIND-STRUCTURE-HEADER ADDR)))
    (COND ((AND (= (%P-DATA-TYPE OBJECT) DTP-SYMBOL-HEADER)
		(NOT (MEMBER OBJECT TARGET-OBJECT-LIST :TEST #'EQ))
		(SYMBOL-PACKAGE OBJECT))
	   ;; Interned symbols are considered to be roots unless they happen to be 
	   ;; one of the objects that we are looking for.
	   (when *VERBOSE*
	     (let ((*print-structure* t) (*print-length* 3) (*print-level* 2))
	       (format t "~&Symbol ~S -> #o~O: ~S~%" OBJECT (%P-POINTER ADDR)
		       (%FIND-STRUCTURE-HEADER (%P-POINTER ADDR)))))
	   (PUSH OBJECT SYMBOL-LIST))
	  ((AND (ARRAYP OBJECT)
		(MEMBER OBJECT PACKAGE-ARRAYS :TEST #'EQ)
		(NOT (MEMBER OBJECT TARGET-OBJECT-LIST :TEST #'EQ)))
	   ;; Disregard pointers from packages to symbols.
	   NIL)
	  (T
	   (COND ((NOT (INSERT-TREE MAX MIN LIST-OF-RANGES)))
		 (T
		  (when *VERBOSE*
		    (let ((*print-structure* t) (*print-length* 3) (*print-level* 2))
		      (format t "~&New range ADDR = #o~O, MIN = #o~O, MAX = #o~O
       OBJECT = ~S ->
		#o~O: ~S~%" ADDR MIN MAX OBJECT (%P-POINTER ADDR)
			      (%FIND-STRUCTURE-HEADER (%P-POINTER ADDR)))))
		  (SETF HIT-FLAG T)
		  (SETF NUMBER-OF-RANGES (1+ NUMBER-OF-RANGES)))))))
  (MAYBE-ABORT-NOW))



(DEFUN SCAN-SECTION (LOW-ADDRESS HIGH-ADDRESS LIST)
  (DO ((ADDR LOW-ADDRESS (%MAKE-POINTER-OFFSET DTP-FIX ADDR 1)))
      ((> ADDR HIGH-ADDRESS))
    (WITHOUT-INTERRUPTS
      (WHEN (AND (%P-POINTERP ADDR)
		 (LET* ((PTR1 (%P-POINTER ADDR))
			(MIN (SEARCH-FOR-GREATER-THAN-OR-EQUAL PTR1 LIST-OF-RANGES)))
		   (AND MIN
			(<= MIN PTR1)))
		 (NOT (SEARCH-FOR-EQUAL ADDR NO-INTEREST-LIST)))
	(ENTER-NEW-RANGE ADDR))))
  (WHEN (AND HIT-FLAG LIST)
    ;; PERFORM A REVERSE SCAN IF WE GOT A HIT IN THIS SEGMENT. THIS EFFICIENCY HACK
    ;; ALLOWS US TO FOLLOW THE NORMAL ORDER FOR NON-CDR-CODED LIST CELLS IN A HURRY
    ;; RATHER THAN GETTING ONLY ONE STEP FOR EACH SCAN OF THE ENTIRE ADDRESS SPACE.
    (DO ((ADDR HIGH-ADDRESS (%MAKE-POINTER-OFFSET DTP-FIX ADDR -1)))
	((< ADDR LOW-ADDRESS))
      (WHEN (AND (%P-POINTERP ADDR)
		 (LET* ((PTR1 (%P-POINTER ADDR))
			(MIN (SEARCH-FOR-GREATER-THAN-OR-EQUAL PTR1 LIST-OF-RANGES)))
		   (AND MIN
			(<= MIN PTR1)))
		 (NOT (SEARCH-FOR-EQUAL ADDR NO-INTEREST-LIST)))
	(ENTER-NEW-RANGE ADDR)))))



(DEFUN SCAN-REGION (REGION AREA)
  (MAYBE-ABORT-NOW)
  (COND ((= (LDB %%REGION-REPRESENTATION-TYPE (REGION-BITS REGION))
	    %REGION-REPRESENTATION-TYPE-LIST)
	 (SETF HIT-FLAG NIL)
	 (SCAN-SECTION (REGION-ORIGIN REGION)
		       (%MAKE-POINTER-OFFSET
			 DTP-FIX
			 (REGION-ORIGIN REGION)
			 (1- (AREF INITIAL-REGION-FREE-POINTER REGION)))
		       T))
	((/= AREA PDL-AREA)
	 (SETF HIT-FLAG T)
	 (DO ()
	     ((NOT HIT-FLAG))
	   (SETF HIT-FLAG NIL)
	   (DO ((OBJ (REGION-ORIGIN REGION)
		     (%MAKE-POINTER-OFFSET DTP-FIX OBJ (%STRUCTURE-TOTAL-SIZE OBJ)))
		(END (%MAKE-POINTER-OFFSET DTP-FIX (REGION-ORIGIN REGION)
					   (AREF INITIAL-REGION-FREE-POINTER REGION))))
	       ((= OBJ END))
	     (SCAN-SECTION OBJ (%MAKE-POINTER-OFFSET DTP-FIX OBJ
						     (1- (%STRUCTURE-BOXED-SIZE OBJ)))
			   NIL))))
	(T
	 (DO ((OBJ (REGION-ORIGIN REGION)
		   (%MAKE-POINTER-OFFSET DTP-FIX OBJ (%STRUCTURE-TOTAL-SIZE OBJ)))
	      (CURRENT-REGULAR-PDL (%MAKE-POINTER DTP-FIX
						  (SG-REGULAR-PDL
						    (PROCESS-STACK-GROUP CURRENT-PROCESS))))
	      (OBJ-END)
	      (END (%MAKE-POINTER-OFFSET DTP-FIX (REGION-ORIGIN REGION)
					 (AREF INITIAL-REGION-FREE-POINTER REGION))))
	     ((= OBJ END))
	   (SETF OBJ-END (%MAKE-POINTER-OFFSET DTP-FIX OBJ
					       (1- (%STRUCTURE-BOXED-SIZE OBJ))))
	   (IF (OR (< CURRENT-REGULAR-PDL OBJ)
		   (< OBJ-END CURRENT-REGULAR-PDL))
	       (SCAN-SECTION OBJ OBJ-END NIL))))))

(DEFUN SCAN-AREA (AREA MAX-GEN)
  (DO ((REGION (AREA-REGION-LIST AREA) (REGION-LIST-THREAD REGION)))
      ((MINUSP REGION))
    (IF (<= (LDB %%REGION-GENERATION (REGION-BITS REGION)) MAX-GEN)
	(SCAN-REGION REGION AREA))))

(DEFVAR LIST-OF-PREVIOUS-OBJECTS)
(DEFVAR REPORTED-OBJECT-LIST)
(DEFVAR UNINTERESTING-OBJECT-LIST)
(DEFVAR PREVIOUS-REPORT-LIST)
(DEFVAR FULLY-PROCESSED-TARGET-LIST)
(DEFVAR REPORTED-TARGET-LIST) ; list of targets for which a reference path has been written.

(PROCLAIM '(LIST LIST-OF-PREVIOUS-OBJECTS TARGET-OBJECT-LIST 
		 REPORTED-OBJECT-LIST  PREVIOUS-REPORT-LIST 
		 FULLY-PROCESSED-TARGET-LIST REPORTED-TARGET-LIST))
(PROCLAIM '(TYPE B-TREE UNINTERESTING-OBJECT-LIST))

(DEFUN SET-TARGET-OBJECT-LIST (FIXNUM-ADDRESS-LIST)
  (SETF TARGET-OBJECT-LIST (MAPCAR #'%FIND-STRUCTURE-HEADER FIXNUM-ADDRESS-LIST))
  (FORMAT T "~%Target objects:")
  (LET ((*PRINT-LENGTH* 8) (*PRINT-LEVEL* 2)
	(*PRINT-ARRAY* *VERBOSE*) (*PRINT-STRUCTURE* *VERBOSE*))
    (DOLIST (OBJECT TARGET-OBJECT-LIST)
      (FRESH-LINE)
      (IF *VERBOSE*
	  (FORMAT T " #<~A ~O>: " (NTH (%DATA-TYPE OBJECT) Q-DATA-TYPES) (%POINTER OBJECT))
	(WRITE-STRING "    "))
      (PRIN1 OBJECT)))
  (FORMAT T "~%")
  (VALUES))

(DEFUN REPORT-INTERESTING-PATH (LIST-OF-OBJECTS)
  (LET ((REVERSE-LIST (REVERSE LIST-OF-OBJECTS))
	(LIST-MATCH-FLAG NIL)
	(*PRINT-LENGTH* 2) (*PRINT-LEVEL* 2) (*PRINT-ARRAY* NIL) (*PRINT-STRUCTURE* NIL))
    (FORMAT T "~&")
    (DO* ((OBJECT-LIST REVERSE-LIST (CDR OBJECT-LIST))
	  (OBJECT (CAR OBJECT-LIST) (CAR OBJECT-LIST))
	  (COUNT 1 (1+ COUNT))
	  (PREVIOUS-OBJECT-LIST PREVIOUS-REPORT-LIST (CDR PREVIOUS-OBJECT-LIST))
	  (PREVIOUS-OBJECT (CAR PREVIOUS-OBJECT-LIST) (CAR PREVIOUS-OBJECT-LIST)))
	 ((NOT OBJECT))
      (WHEN (OR LIST-MATCH-FLAG
		(NEQ OBJECT PREVIOUS-OBJECT))
	(SETF LIST-MATCH-FLAG T)
	(PUSHNEW OBJECT REPORTED-OBJECT-LIST :TEST #'EQ)
	(FORMAT T "~%")
	(DOTIMES (I COUNT)
	  (FORMAT T " "))
	(FORMAT T "~D " COUNT)
	(DISPLAY-LINK OBJECT (SECOND OBJECT-LIST))
	(WHEN (MEMBER OBJECT TARGET-OBJECT-LIST :TEST #'EQ)
	  (comment
	    (FORMAT *DEBUG-IO* "  ********~D."
		    (POSITION OBJECT TARGET-OBJECT-LIST :TEST #'EQ)) )
	  (UNLESS (MEMBER OBJECT REPORTED-TARGET-LIST :TEST #'EQ)
	    (PUSH OBJECT REPORTED-TARGET-LIST)))))
    (SETF PREVIOUS-REPORT-LIST REVERSE-LIST)))

(DEFUN DISPLAY-LINK (OBJECT &OPTIONAL NEXT-OBJECT)
  (IF (= (%DATA-TYPE OBJECT) DTP-LIST)
      (IF (EQL (%P-CDR-CODE OBJECT) CDR-NEXT)	; cdr-coded list
	  (PROGN (FORMAT T "List at #o~O : ~S"
			  (%MAKE-POINTER DTP-FIX OBJECT) OBJECT)
		 (WHEN NEXT-OBJECT
		   (LET ((INDEX (POSITION NEXT-OBJECT (THE LIST OBJECT) :TEST #'EQ)))
		     (WHEN INDEX
		       (FORMAT T " element ~D." INDEX)))))
	(FORMAT T "Cons at #o~O : ~S"
		 (%MAKE-POINTER DTP-FIX OBJECT) OBJECT))
    (PROGN (FORMAT T "~S"  OBJECT)
	   (WHEN NEXT-OBJECT ; try to tell where the next object is in the structure.
	     (IGNORE-ERRORS 
	       (TYPECASE OBJECT
		 (VECTOR
		  (LET ((INDEX (POSITION NEXT-OBJECT (THE VECTOR OBJECT) :TEST #'EQ)))
		    (WHEN INDEX
		      (FORMAT T " index ~D." INDEX))))
		 (SYMBOL (COND ((AND (BOUNDP OBJECT)
				     (EQ NEXT-OBJECT (SYMBOL-VALUE OBJECT)))
				(FORMAT T " value cell"))
			       ((AND (FBOUNDP OBJECT)
				     (EQ NEXT-OBJECT (SYMBOL-FUNCTION OBJECT)))
				(FORMAT T " function cell"))
			       ((EQ NEXT-OBJECT (SYMBOL-PLIST OBJECT))
				(FORMAT T " plist cell"))
			       ((EQ NEXT-OBJECT (SYMBOL-NAME OBJECT))
				(FORMAT T " name cell"))
			       ((EQ NEXT-OBJECT (SYMBOL-PACKAGE OBJECT))
				(FORMAT T " package cell"))
			       ))
		 (INSTANCE 
		  (DOLIST (IVAR (FLAVOR-ALL-INSTANCE-VARIABLES
				  (INSTANCE-FLAVOR OBJECT)))
		    (LET ((LOC (LOCATE-IN-INSTANCE OBJECT IVAR)))
		      (WHEN (AND (LOCATION-BOUNDP LOC)
				 (EQ (CONTENTS LOC) NEXT-OBJECT))
			(FORMAT T " slot ~S" IVAR)
			(RETURN)))))
		 )))))
  (VALUES))

(DEFUN REPORT-OBJECT (OBJECT)
  (PUSH OBJECT LIST-OF-PREVIOUS-OBJECTS)
  (UNLESS (MEMBER OBJECT FULLY-PROCESSED-TARGET-LIST :TEST #'EQ)
    (DO* ((ADDR (%MAKE-POINTER DTP-FIX (%FIND-STRUCTURE-LEADER OBJECT))
		(%MAKE-POINTER-OFFSET DTP-FIX ADDR 1.))
	  (MAX-ADDR (%MAKE-POINTER-OFFSET
		      DTP-FIX
		      ADDR
		      (IF (/= (%DATA-TYPE OBJECT) DTP-LIST)
			  (%STRUCTURE-BOXED-SIZE ADDR)
			(IF (AND (> (%STRUCTURE-BOXED-SIZE ADDR) 1.)
				 (= (%P-DATA-TYPE
				      (%MAKE-POINTER-OFFSET
					DTP-FIX ADDR
					(- (%STRUCTURE-BOXED-SIZE ADDR) 2.)))
				    DTP-HEADER-FORWARD))
			    (1- (%STRUCTURE-BOXED-SIZE ADDR))
			  (%STRUCTURE-BOXED-SIZE ADDR))))))
	 ((= ADDR MAX-ADDR))
      (WHEN (AND (%P-POINTERP ADDR)
		 (LET* ((PTR1 (%P-POINTER ADDR))
			(MIN (SEARCH-FOR-GREATER-THAN-OR-EQUAL PTR1 LIST-OF-RANGES)))
		   (AND MIN
			(<= MIN PTR1)))
		 (NOT (MEMBER (%FIND-STRUCTURE-HEADER (%P-POINTER ADDR))
			      LIST-OF-PREVIOUS-OBJECTS :TEST #'EQ))
		 (NOT (SEARCH-FOR-EQUAL (%MAKE-POINTER
					  DTP-FIX (%FIND-STRUCTURE-HEADER
						    (%P-POINTER ADDR)))
					UNINTERESTING-OBJECT-LIST)))
	(REPORT-OBJECT (%FIND-STRUCTURE-HEADER (%P-POINTER ADDR)))))
    (IF (NOT (MEMBER (CAR LIST-OF-PREVIOUS-OBJECTS) TARGET-OBJECT-LIST
		     :TEST #'EQ))
	(IF (NOT (MEMBER (CAR LIST-OF-PREVIOUS-OBJECTS) REPORTED-OBJECT-LIST
			 :TEST #'EQ)) 
	    (INSERT-TREE (%MAKE-POINTER DTP-FIX (CAR LIST-OF-PREVIOUS-OBJECTS))
			 0. UNINTERESTING-OBJECT-LIST)
	    (PUSH (CAR LIST-OF-PREVIOUS-OBJECTS) FULLY-PROCESSED-TARGET-LIST))))
  (IF (NOT (SEARCH-FOR-EQUAL (%MAKE-POINTER DTP-FIX OBJECT)
			     UNINTERESTING-OBJECT-LIST))
      (REPORT-INTERESTING-PATH LIST-OF-PREVIOUS-OBJECTS))
  (POP LIST-OF-PREVIOUS-OBJECTS))

#|
(DEFUN REPORT-ANNOTATED-TARGET-LIST ()
  (DOLIST (OBJECT TARGET-OBJECT-LIST)
    (FORMAT *DEBUG-IO* "~%~S" OBJECT)
    (WHEN (MEMBER OBJECT REPORTED-TARGET-LIST :TEST #'EQ)
      (FORMAT *DEBUG-IO* "********~D."
	      (POSITION OBJECT TARGET-OBJECT-LIST :TEST #'EQ))))
  (VALUES))
|#

(DEFUN REPORT-SYMBOLS ()
  (LET ((REPORTED-TARGET-LIST NIL)
	(LIST-OF-PREVIOUS-OBJECTS NIL)
	(FULLY-PROCESSED-TARGET-LIST NIL)
	(PREVIOUS-REPORT-LIST NIL)
	(REPORTED-OBJECT-LIST NIL)
	(UNINTERESTING-OBJECT-LIST (CREATE-TREE)))
    (DOLIST (SYMBOL (REVERSE SYMBOL-LIST))
      (REPORT-OBJECT SYMBOL))
    (FORMAT T "~%")
    (comment
      (REPORT-ANNOTATED-TARGET-LIST) )
    (REPORT-STATIC-REGIONS LIST-OF-RANGES)
    (VALUES)))


(DEFUN INVERT-TREE (VALUE-LIST &OPTIONAL *VERBOSE*
		    &AUX TARGET-OBJECT-LIST (GC-GEN %GC-GENERATION-NUMBER))
  "Show who points to objects in memory.  The argument is a list of things to 
look for; each element is either an object or the integer address of an object 
in memory."
  (DECLARE (ARGLIST VALUE-LIST &OPTIONAL VERBOSE-P))
  (UNLESS (LISTP VALUE-LIST) (SETQ VALUE-LIST (LIST VALUE-LIST)))
  (GC-OFF) ; so nothing moves after this.
  (SETF VALUE-LIST ; list of addresses
	(MAPCAR #'(LAMBDA (X)
		    (COND ((INTEGERP X)		; memory address
			   (CONVERT-TO-SIGNED X)) ; make sure it is a fixnum
			  ((%POINTERP X)	; pointer to object of interest
			   (%POINTER X))	; the address as a fixnum
			  (T (ERROR "Invalid argument to INVERT-TREE:  ~S" X))))
		VALUE-LIST))
  (SET-TARGET-OBJECT-LIST VALUE-LIST)
  (WHEN (FIND-PACKAGE "DOC")
    (LET ((VAR (FIND-SYMBOL "*XREF-HASH-TABLE*" "DOC")))
      (WHEN (AND VAR (BOUNDP VAR)
		 (NOT (NULL (SYMBOL-VALUE VAR)))
		 (NOT (ZEROP (HASH-TABLE-COUNT (SYMBOL-VALUE VAR))))
		 (YES-OR-NO-P "Discard Documenter cross-reference table first?"))
	;; Best to get rid of this data because it makes INVERT-TREE take much longer 
	;; when it is trying to track down references in this table, which aren't 
	;; interesting anyway.
	(FUNCALL (FIND-SYMBOL "ERASE-XREF-TABLE" "DOC"))
	(GC-IMMEDIATELY :MAX-GEN 1 :PROMOTE NIL))))
  (WHEN (TRAIN-SPACE-EXISTS-P)
    ;; this utility doesn't know how to handle train space regions.
    (TRAINING-OFF))  
  (UNLESS (EQL %GC-GENERATION-NUMBER GC-GEN)
    ;; need to recompute the addresses
    (SETF VALUE-LIST (MAPCAR #'%POINTER TARGET-OBJECT-LIST))
    (WHEN *VERBOSE* (SET-TARGET-OBJECT-LIST VALUE-LIST)))
  ;; Clear read-eval-print loop history to prevent finding references there.
  (SETQ + NIL ++ NIL +++ NIL - NIL / NIL // NIL /// NIL
	* NIL ** NIL *** NIL *VALUES* NIL)
  (SET 'SI::TOP-LEVEL-FORM NIL) ; used in EVAL-ABORT-TRIVIAL-ERRORS

  (LET (NUMBER-OF-RANGES-AT-START-OF-SCAN (MAX-GEN 2)
	 REPORTED-TARGET-LIST REPORTED-OBJECT-LIST
	(SYMBOL-LIST NIL)
	(PACKAGE-ARRAYS (MAPCAR #'PACK-SYMBOL-TABLE (LIST-ALL-PACKAGES)))
	(INITIAL-REGION-FREE-POINTER (MAKE-ARRAY SIZE-OF-REGION-ARRAYS)))
    (DOTIMES (REGION SIZE-OF-REGION-ARRAYS)
      (IF (= (LDB %%REGION-SPACE-TYPE (REGION-BITS REGION)) %REGION-SPACE-FREE)
	  (SETF (AREF INITIAL-REGION-FREE-POINTER REGION) 0.)
	(SETF (AREF INITIAL-REGION-FREE-POINTER REGION)
	      (REGION-FREE-POINTER REGION))))
    (LET ((LIST-OF-RANGES (CREATE-TREE))
	  (NO-INTEREST-LIST (CREATE-TREE))
	  (NUMBER-OF-RANGES 0))
      (DOLIST (ITEM VALUE-LIST)
	(ENTER-NEW-RANGE ITEM))
      (DOTIMES (I 1000000.)
	(SETF NUMBER-OF-RANGES-AT-START-OF-SCAN NUMBER-OF-RANGES)
	(FORMAT T "~%Pass ~D with max-gen ~D" I MAX-GEN)
	(DOLIST (AREA-NAME AREA-LIST)
	  (DECLARE (UNSPECIAL AREA-NAME))
	  (LET ((AREA-NUMBER (SYMBOL-VALUE AREA-NAME)))
	    (IF (AND (>= AREA-NUMBER WORKING-STORAGE-AREA)
		     (/= AREA-NUMBER #+ELROY INDIRECTION-CELL-AREA
			 #-ELROY TGC-INDIRECTION-CELL-AREA))
		(SCAN-AREA AREA-NUMBER MAX-GEN))))
	(FORMAT T " finished with ~D. new ranges and ~D. total ranges."
		(- NUMBER-OF-RANGES NUMBER-OF-RANGES-AT-START-OF-SCAN)
		NUMBER-OF-RANGES)
	(IF (AND (= NUMBER-OF-RANGES NUMBER-OF-RANGES-AT-START-OF-SCAN)
		 (= MAX-GEN 3))
	    (PROGN
	      (REPORT-SYMBOLS)
	      (RETURN))
	  (IF (= NUMBER-OF-RANGES NUMBER-OF-RANGES-AT-START-OF-SCAN)
	      (SETF MAX-GEN 3)
	    (SETF MAX-GEN 2))))
      ))
  (VALUES))


(DEFUN INACTIVE-STACK-GROUPS ()
  (GC-OFF)
  (LET ((SGL NIL))
    (DECLARE (LIST SGL))
    (DECLARE (SPECIAL EH:ERROR-STACK-GROUP))
    (DO ((REGION (AREA-REGION-LIST #+ELROY SG-AND-BIND-PDL-AREA
				   #-ELROY STACK-GROUP-AND-BINDING-PDL-AREA)
		 (REGION-LIST-THREAD REGION)))
	((MINUSP REGION))
      (DO ((OBJ (REGION-ORIGIN REGION) (%MAKE-POINTER-OFFSET
					 DTP-FIX OBJ (%STRUCTURE-TOTAL-SIZE OBJ)))
	   (OBJ-HEADER)
	   (END (%MAKE-POINTER-OFFSET DTP-FIX (REGION-ORIGIN REGION)
				      (REGION-FREE-POINTER REGION))))
	  ((= OBJ END))
	(SETF OBJ-HEADER (%MAKE-POINTER DTP-FIX (%FIND-STRUCTURE-HEADER OBJ)))
	(IF (AND (= DTP-ARRAY-HEADER
		    (%P-DATA-TYPE OBJ-HEADER))
		 (= (LDB %%ARRAY-TYPE-FIELD ART-STACK-GROUP-HEAD)
		    (LDB %%ARRAY-TYPE-FIELD (%P-POINTER OBJ-HEADER))))
	    (SETF SGL (PUSH OBJ-HEADER SGL)))))
    ;
    ; REMOVE STACK GROUPS FOR PROCESSES ON THE ALL PROCESS LIST FROM THE SG LIST.
    ;
    (DOLIST (PROCESS ALL-PROCESSES)
      ;
      ; ALSO REMOVE THE PREVIOUS STACK GROUP FROM ANY PROCESS ON THE ALL PROCESSES LIST.
      ;
      (IF (= DTP-STACK-GROUP (%DATA-TYPE (PROCESS-STACK-GROUP PROCESS)))
	  (SETF SGL (DELETE (%MAKE-POINTER DTP-FIX (SG-PREVIOUS-STACK-GROUP
						     (PROCESS-STACK-GROUP PROCESS)))
			    SGL)))
      (SETF SGL (DELETE (%MAKE-POINTER DTP-FIX (PROCESS-STACK-GROUP PROCESS))
			SGL)))
    ;
    ; REMOVE THE SPARE PROCESSES FROM THE SG-LIST
    ;
    (DOLIST (PROCESS PROCESS-RUN-FUNCTION-SPARE-PROCESSES)
      (SETF SGL (DELETE (%MAKE-POINTER DTP-FIX (PROCESS-STACK-GROUP PROCESS))
			SGL)))
    ;
    ; REMOVE THE SCHEDULER STACK-GROUP FROM THE SG LIST
    ;
    (SETF SGL (DELETE (%MAKE-POINTER DTP-FIX SCHEDULER-STACK-GROUP) SGL))
    ;
    ; REMOVE THE FOOTHOLD AUX STACK-GROUP FROM THE SG-LIST
    ;
    (SETF SGL (DELETE (%MAKE-POINTER DTP-FIX #+ELROY EH:*FH-AUX-SG*
				     #-ELROY EH:FH-AUX-SG) SGL))
    ;
    ; REMOVE THE FIRST LEVEL ERROR HANDLER STACK-GROUP FROM THE LIST
    ;
    (SETF SGL (DELETE (%MAKE-POINTER DTP-FIX #+ELROY EH:ERROR-STACK-GROUP
				     #-ELROY SI:ERROR-STACK-GROUP) SGL))
    ;
    ; REMOVE THE FREE SECOND-LEVEL ERROR HANDLER STACK GROUPS FROM THE LIST
    ;
    (DOLIST (OBJECT #+ELROY EH:*FREE-SECOND-LEVEL-ERROR-HANDLER-SG-LIST*
		    #-ELROY EH:FREE-SECOND-LEVEL-ERROR-HANDLER-SG-LIST)
      (SETF SGL (DELETE (%MAKE-POINTER DTP-FIX OBJECT) SGL)))
    SGL))


(DEFUN EXPLAIN-INACTIVE-STACK-GROUPS ()
  (INVERT-TREE (INACTIVE-STACK-GROUPS)))



(DEFUN SCAN-SECTION-FOR-POINTERS-TO-INACTIVE-OBJECTS (LOW-ADDR HIGH-ADDR GEN USAGE LIST)
  (IF (> (LENGTH LIST) 100.) (THROW 'LIST-FULL LIST))
  (DO ((ADDR LOW-ADDR (%MAKE-POINTER-OFFSET DTP-FIX ADDR 1.))
       REGION-NUMBER)
      ((> ADDR HIGH-ADDR))
    (WITHOUT-INTERRUPTS
      (WHEN (AND (%P-POINTERP ADDR)
		 (SETF REGION-NUMBER (%REGION-NUMBER (%P-POINTER ADDR))))
	(LET ((BITS (REGION-BITS REGION-NUMBER)))
	  (WHEN (AND (= (LDB %%REGION-GENERATION BITS) GEN)
		     (>= (LDB %%REGION-USAGE BITS) USAGE))
	    (LET ((OBJ-ADDR (%MAKE-POINTER
			      DTP-FIX (%FIND-STRUCTURE-LEADER (%P-POINTER ADDR)))))
	      (WHEN (NOT (MEMBER OBJ-ADDR LIST))
		(PUSH OBJ-ADDR LIST))))))))
  LIST)



(DEFUN INACTIVE-OBJECTS (&OPTIONAL (GEN 2) (USAGE 3) &AUX (LIST NIL))
  (CATCH 'LIST-FULL
    (DOLIST (AREA AREA-LIST)
      (LET ((AREA-NUMBER (SYMBOL-VALUE AREA)))
	(WHEN (AND (>= AREA-NUMBER WORKING-STORAGE-AREA)
		   (/= AREA-NUMBER INDIRECTION-CELL-AREA))
	  (DO ((REGION (AREA-REGION-LIST AREA-NUMBER) (REGION-LIST-THREAD REGION)))
	      ((MINUSP REGION))
	    (LET* ((BITS (REGION-BITS REGION))
		   (REGION-GENERATION (LDB %%REGION-GENERATION BITS))
		   (REGION-USAGE (LDB %%REGION-USAGE BITS)))
	      (WHEN (OR (/= REGION-GENERATION GEN)
			(< REGION-USAGE USAGE))
		(COND ((= (LDB %%REGION-REPRESENTATION-TYPE BITS)
			  %REGION-REPRESENTATION-TYPE-LIST)
		       (SETF LIST (SCAN-SECTION-FOR-POINTERS-TO-INACTIVE-OBJECTS
				    (REGION-ORIGIN REGION)
				    (%MAKE-POINTER-OFFSET DTP-FIX
							  (REGION-ORIGIN REGION)
							  (1- (REGION-FREE-POINTER REGION)))
				    GEN USAGE LIST)))
		      ((/= AREA-NUMBER PDL-AREA)
		       (DO ((OBJ (REGION-ORIGIN REGION)
				 (%MAKE-POINTER-OFFSET DTP-FIX OBJ
						       (%STRUCTURE-TOTAL-SIZE OBJ)))
			    (END (%MAKE-POINTER-OFFSET DTP-FIX
						       (REGION-ORIGIN REGION)
						       (REGION-FREE-POINTER REGION))))
			   ((= OBJ END))
			 (SETF LIST (SCAN-SECTION-FOR-POINTERS-TO-INACTIVE-OBJECTS
				      OBJ
				      (%MAKE-POINTER-OFFSET
					DTP-FIX OBJ (1- (%STRUCTURE-BOXED-SIZE OBJ)))
				      GEN USAGE LIST))))
		      (T
		       (DO ((OBJ (REGION-ORIGIN REGION)
				 (%MAKE-POINTER-OFFSET
				   DTP-FIX OBJ (%STRUCTURE-TOTAL-SIZE OBJ)))
			    (CURRENT-REGULAR-PDL
			      (%MAKE-POINTER DTP-FIX (SG-REGULAR-PDL
						       (PROCESS-STACK-GROUP CURRENT-PROCESS))))
			    (OBJ-END)
			    (END (%MAKE-POINTER-OFFSET DTP-FIX
						       (REGION-ORIGIN REGION)
						       (REGION-FREE-POINTER REGION))))
			   ((= OBJ END))
			 (SETF OBJ-END (%MAKE-POINTER-OFFSET
					 DTP-FIX OBJ (1- (%STRUCTURE-BOXED-SIZE OBJ))))
			 (IF (OR (< CURRENT-REGULAR-PDL OBJ)
				 (< OBJ-END CURRENT-REGULAR-PDL))
			     (SETF LIST
				   (SCAN-SECTION-FOR-POINTERS-TO-INACTIVE-OBJECTS
				     OBJ OBJ-END GEN USAGE LIST)))))))))))))
  LIST)

 
(DEFUN EXPLAIN-INACTIVE-OBJECTS (&OPTIONAL (GEN 2) (USAGE 3))
  (INVERT-TREE (INACTIVE-OBJECTS GEN USAGE)))


(DEFUN BIG-OBJECT-LIST (&AUX (LIST NIL))
  (DOTIMES (REGION SIZE-OF-REGION-ARRAYS)
    (IF (AND (/= (REGION-BITS REGION) 0)
	     (> (REGION-LENGTH REGION) %ADDRESS-SPACE-QUANTUM-SIZE))
	(PUSH (REGION-ORIGIN REGION) LIST)))
  LIST)

(DEFUN EXPLAIN-BIG-OBJECTS ()
  (INVERT-TREE (BIG-OBJECT-LIST)))

(DEFUN STATIC-REGION-P (REGION)
  (LET ((TYPE (LDB %%REGION-SPACE-TYPE (AREF #'REGION-BITS REGION))))
    (OR (EQL type %REGION-SPACE-STATIC)
	(EQL type %REGION-SPACE-FIXED))))

(DEFUN REPORT-STATIC-REGIONS (TREE)
  (when (eq *VERBOSE* :debug)
    (let ((*print-structure* t) (*print-length* 6) (*print-level* 2))
      (format t "~&REPORT-STATIC-REGIONS[ ~S ]~%" tree)))
  (COND ((NULL TREE))
	((>= (LENGTH REPORTED-TARGET-LIST)
	     (LENGTH TARGET-OBJECT-LIST)))
	(T (LET* ((ADR (B-TREE-SEARCH-VALUE TREE))
		  (OBJECT (AND ADR (%FIND-STRUCTURE-HEADER ADR))))
	     (WHEN (AND OBJECT
			(NOT (MEMBER OBJECT SYMBOL-LIST :TEST #'EQ))
			(NOT (MEMBER OBJECT REPORTED-OBJECT-LIST :TEST #'EQ))
			(STATIC-REGION-P (%REGION-NUMBER OBJECT)))
	       (FORMAT T "~%In static region ~D." (%REGION-NUMBER OBJECT))
	       (REPORT-OBJECT OBJECT)))
	   (REPORT-STATIC-REGIONS (B-TREE-LEFT-LINK TREE))
	   (REPORT-STATIC-REGIONS (B-TREE-RIGHT-LINK TREE)) ))
  (VALUES))
